[COMMITTED 01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning,Error}

[COMMITTED 01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning,Error}

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

With the same level as for 'Size, that is to say, full evaluation of the
boolean expressions it may be contained in and handling of private types.

gcc/ada/

	* sem_attr.adb (Analyze_Attribute) <Attribute_Size>: Remove special
	processing for pragma Compile_Time_{Warning,Error}.
	(Eval_Attribute.Compile_Time_Known_Attribute): Set Is_Static on the
	resulting value if In_Compile_Time_Warning_Or_Error is set.
	(Eval_Attribute.Full_Type): New helper function.
	(Eval_Attribute): Call Full_Type for type attributes.  Add handling
	of Object_Size and adjust that of Max_Size_In_Storage_Elements in
	the non-static case.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_attr.adb | 129 ++++++++++++++++++++++---------------------
 1 file changed, 65 insertions(+), 64 deletions(-)

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index c78b11bbd17..629033ca5ac 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6448,49 +6448,6 @@ package body Sem_Attr is
          Check_Not_CPP_Type;
          Set_Etype (N, Universal_Integer);
 
-         --  If we are processing pragmas Compile_Time_Warning and Compile_
-         --  Time_Errors after the back end has been called and this occurrence
-         --  of 'Size is known at compile time then it is safe to perform this
-         --  evaluation. Needed to perform the static evaluation of the full
-         --  boolean expression of these pragmas. Note that Known_RM_Size is
-         --  sometimes True when Size_Known_At_Compile_Time is False, when the
-         --  back end has computed it.
-
-         if In_Compile_Time_Warning_Or_Error
-           and then Is_Entity_Name (P)
-           and then (Is_Type (Entity (P))
-                      or else Ekind (Entity (P)) = E_Enumeration_Literal)
-           and then (Known_RM_Size (Entity (P))
-                       or else Size_Known_At_Compile_Time (Entity (P)))
-         then
-            declare
-               Prefix_E : Entity_Id := Entity (P);
-               Siz      : Uint;
-
-            begin
-               --  Handle private and incomplete types
-
-               if Present (Underlying_Type (Prefix_E)) then
-                  Prefix_E := Underlying_Type (Prefix_E);
-               end if;
-
-               if Known_Static_RM_Size (Prefix_E) then
-                  Siz := RM_Size (Prefix_E);
-               else
-                  Siz := Esize (Prefix_E);
-               end if;
-
-               --  Protect the frontend against cases where the attribute
-               --  Size_Known_At_Compile_Time is set, but the Esize value
-               --  is not available (see Einfo.ads).
-
-               if Present (Siz) then
-                  Rewrite (N, Make_Integer_Literal (Sloc (N), Siz));
-                  Analyze (N);
-               end if;
-            end;
-         end if;
-
       -----------
       -- Small --
       -----------
@@ -7867,6 +7824,9 @@ package body Sem_Attr is
       --  Computes the Fore value for the current attribute prefix, which is
       --  known to be a static fixed-point type. Used by Fore and Width.
 
+      function Full_Type (Typ : Entity_Id) return Entity_Id;
+      --  Return the Underlying_Type of Typ if it exists, otherwise return Typ
+
       function Mantissa return Uint;
       --  Returns the Mantissa value for the prefix type
 
@@ -7930,7 +7890,13 @@ package body Sem_Attr is
          T : constant Entity_Id := Etype (N);
 
       begin
-         Fold_Uint (N, Val, False);
+         --  If we are processing a pragma Compile_Time_{Warning,Error} after
+         --  the back end has been called and the value of this attribute is
+         --  known at compile time, then it is safe to perform its evaluation
+         --  as static. This is needed to perform the evaluation of the full
+         --  boolean expression of these pragmas.
+
+         Fold_Uint (N, Val, Static => In_Compile_Time_Warning_Or_Error);
 
          --  Check that result is in bounds of the type if it is static
 
@@ -7994,6 +7960,22 @@ package body Sem_Attr is
          return R;
       end Fore_Value;
 
+      ---------------
+      -- Full_Type --
+      ---------------
+
+      function Full_Type (Typ : Entity_Id) return Entity_Id is
+         Underlying_Typ : constant Entity_Id := Underlying_Type (Typ);
+
+      begin
+         if Present (Underlying_Typ) then
+            return Underlying_Typ;
+
+         else
+            return Typ;
+         end if;
+      end Full_Type;
+
       --------------
       -- Mantissa --
       --------------
@@ -8655,25 +8637,40 @@ package body Sem_Attr is
       --  for a size from an attribute definition clause). At this stage, this
       --  can happen only for types (e.g. record types) for which the size is
       --  always non-static. We exclude generic types from consideration (since
-      --  they have bogus sizes set within templates). We can also fold
-      --  Max_Size_In_Storage_Elements in the same cases.
+      --  they have bogus sizes set within templates).
+
+      elsif Id = Attribute_Size
+        and then Is_Type (P_Entity)
+        and then not Is_Generic_Type (P_Entity)
+        and then Known_Static_RM_Size (Full_Type (P_Entity))
+      then
+         Compile_Time_Known_Attribute (N, RM_Size (Full_Type (P_Entity)));
+         return;
+
+      --  We can also fold 'Object_Size applied to a type if the object size is
+      --  known (as happens for a size from an attribute definition clause). At
+      --  this stage, this can happen only for types (e.g. record types) for
+      --  which the size is always non-static. We exclude generic types from
+      --  consideration (since they have bogus sizes set within templates).
+      --  We can also fold Max_Size_In_Storage_Elements in the same cases.
 
-      elsif (Id = Attribute_Size or
+      elsif (Id = Attribute_Object_Size or
              Id = Attribute_Max_Size_In_Storage_Elements)
         and then Is_Type (P_Entity)
         and then not Is_Generic_Type (P_Entity)
-        and then Known_Static_RM_Size (P_Entity)
+        and then Known_Static_Esize (Full_Type (P_Entity))
       then
          declare
-            Attr_Value : Uint := RM_Size (P_Entity);
+            Attr_Value : Uint := Esize (Full_Type (P_Entity));
+
          begin
             if Id = Attribute_Max_Size_In_Storage_Elements then
-               Attr_Value := (Attr_Value + System_Storage_Unit - 1)
-                             / System_Storage_Unit;
+               Attr_Value := (Attr_Value + System_Storage_Unit - 1) /
+                                                           System_Storage_Unit;
             end if;
             Compile_Time_Known_Attribute (N, Attr_Value);
+            return;
          end;
-         return;
 
       --  We can fold 'Alignment applied to a type if the alignment is known
       --  (as happens for an alignment from an attribute definition clause).
@@ -8684,9 +8681,9 @@ package body Sem_Attr is
       elsif Id = Attribute_Alignment
         and then Is_Type (P_Entity)
         and then not Is_Generic_Type (P_Entity)
-        and then Known_Alignment (P_Entity)
+        and then Known_Alignment (Full_Type (P_Entity))
       then
-         Compile_Time_Known_Attribute (N, Alignment (P_Entity));
+         Compile_Time_Known_Attribute (N, Alignment (Full_Type (P_Entity)));
          return;
 
       --  If this is an access attribute that is known to fail accessibility
@@ -9033,7 +9030,7 @@ package body Sem_Attr is
       ---------------
 
       when Attribute_Alignment => Alignment_Block : declare
-         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+         P_TypeA : constant Entity_Id := Full_Type (P_Type);
 
       begin
          --  Fold if alignment is set and not otherwise
@@ -9765,7 +9762,7 @@ package body Sem_Attr is
       --  Note: Machine_Size is identical to Object_Size
 
       when Attribute_Machine_Size => Machine_Size : declare
-         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+         P_TypeA : constant Entity_Id := Full_Type (P_Type);
 
       begin
          if Known_Esize (P_TypeA) then
@@ -9900,13 +9897,17 @@ package body Sem_Attr is
       --  Storage_Unit boundary. We can fold any cases for which the size
       --  is known by the front end.
 
-      when Attribute_Max_Size_In_Storage_Elements =>
-         if Known_Esize (P_Type) then
+      when Attribute_Max_Size_In_Storage_Elements => Max_Size : declare
+         P_TypeA : constant Entity_Id := Full_Type (P_Type);
+
+      begin
+         if Known_Esize (P_TypeA) then
             Fold_Uint (N,
-              (Esize (P_Type) + System_Storage_Unit - 1) /
+              (Esize (P_TypeA) + System_Storage_Unit - 1) /
                                           System_Storage_Unit,
                Static);
          end if;
+      end Max_Size;
 
       --------------------
       -- Mechanism_Code --
@@ -10020,7 +10021,7 @@ package body Sem_Attr is
       --  type and can be folded if this value is known.
 
       when Attribute_Object_Size => Object_Size : declare
-         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+         P_TypeA : constant Entity_Id := Full_Type (P_Type);
 
       begin
          if Known_Esize (P_TypeA) then
@@ -10338,7 +10339,7 @@ package body Sem_Attr is
          | Attribute_VADS_Size
       =>
          Size : declare
-            P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+            P_TypeA : constant Entity_Id := Full_Type (P_Type);
 
          begin
             pragma Assert
@@ -10494,7 +10495,7 @@ package body Sem_Attr is
       ----------------
 
       when Attribute_Type_Class => Type_Class : declare
-         Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
+         Typ : constant Entity_Id := Full_Type (P_Base_Type);
          Id  : RE_Id;
 
       begin
@@ -10558,7 +10559,7 @@ package body Sem_Attr is
       -------------------------
 
       when Attribute_Unconstrained_Array => Unconstrained_Array : declare
-         Typ : constant Entity_Id := Underlying_Type (P_Type);
+         Typ : constant Entity_Id := Full_Type (P_Type);
 
       begin
          Rewrite (N, New_Occurrence_Of (
@@ -10616,7 +10617,7 @@ package body Sem_Attr is
       --  it is annoying that a size of zero means two things!
 
       when Attribute_Value_Size => Value_Size : declare
-         P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+         P_TypeA : constant Entity_Id := Full_Type (P_Type);
 
       begin
          pragma Assert
-- 
2.43.2

[COMMITTED 02/35] ada: Small cleanup in aggregate expansion code

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

This patch moves a statement outside of a loop because it didn't
need to be inside that loop. The behavior of the program is not
affected.

gcc/ada/

	* exp_aggr.adb (Flatten): Small cleanup.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_aggr.adb | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 5d2b334722a..cff04fc1b79 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4626,6 +4626,14 @@ package body Exp_Aggr is
             Component_Loop : while Present (Elmt) loop
                Expr := Expression (Elmt);
 
+               --  If the expression involves a construct that generates a
+               --  loop, we must generate individual assignments and no
+               --  flattening is possible.
+
+               if Nkind (Expr) = N_Quantified_Expression then
+                  return False;
+               end if;
+
                --  In the case of a multidimensional array, check that the
                --  aggregate can be recursively flattened.
 
@@ -4642,14 +4650,6 @@ package body Exp_Aggr is
                   if Nkind (Choice) = N_Others_Choice then
                      Rep_Count := 0;
 
-                     --  If the expression involves a construct that generates
-                     --  a loop, we must generate individual assignments and
-                     --  no flattening is possible.
-
-                     if Nkind (Expr) = N_Quantified_Expression then
-                        return False;
-                     end if;
-
                      for J in Vals'Range loop
                         if No (Vals (J)) then
                            Vals (J)  := New_Copy_Tree (Expr);
-- 
2.43.2

[COMMITTED 03/35] ada: Remove superfluous Relocate_Node calls

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

This patch removes two calls to Relocate_Node that were not needed.
This does not affect the behavior of the compiler.

gcc/ada/

	* exp_ch4.adb (Expand_N_Case_Expression): Remove call to
	Relocate_Node.
	* sem_attr.adb (Analyze_Attribute): Likewise.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_ch4.adb  | 2 +-
 gcc/ada/sem_attr.adb | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 448cd5c82b6..42d18f77771 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -5109,7 +5109,7 @@ package body Exp_Ch4 is
                   else
                      Alt_Expr :=
                        Make_Attribute_Reference (Alt_Loc,
-                         Prefix         => Relocate_Node (Alt_Expr),
+                         Prefix         => Alt_Expr,
                          Attribute_Name => Name_Unrestricted_Access);
                   end if;
                end if;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 629033ca5ac..a921909685a 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3425,7 +3425,7 @@ package body Sem_Attr is
       --  perform legality checks on the original tree.
 
       if Nkind (P) in N_Raise_xxx_Error then
-         Rewrite (N, Relocate_Node (P));
+         Rewrite (N, P);
          P := Original_Node (P_Old);
       end if;
 
-- 
2.43.2

[COMMITTED 04/35] ada: Fix checking range constraints within composite types

[Marc Poulhiès]

From: Viljar Indus <indus@adacore.com>

Subtype indications were never analyzed if they were
within composite types. Analyze them explicitly within
Analyze_Component_Declaration.

gcc/ada/

	* sem_ch3.adb (Analyze_Component_Declaration):
	Add Range_Checks for Subtype_Indications

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_ch3.adb | 50 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c3f216c826c..7ee4ca299d9 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1965,6 +1965,9 @@ package body Sem_Ch3 is
       --  a limited type. Used to validate declaration against that of
       --  enclosing record.
 
+      procedure Add_Range_Checks (Subt_Indic : Node_Id);
+      --  Adds range constraint checks for a subtype indication
+
       ----------------------
       -- Is_Known_Limited --
       ----------------------
@@ -1999,6 +2002,50 @@ package body Sem_Ch3 is
          end if;
       end Is_Known_Limited;
 
+      ----------------------
+      -- Add_Range_Checks --
+      ----------------------
+
+      procedure Add_Range_Checks (Subt_Indic : Node_Id)
+      is
+
+      begin
+         if Present (Subt_Indic) and then
+           Nkind (Subt_Indic) = N_Subtype_Indication and then
+           Nkind (Constraint (Subt_Indic)) = N_Index_Or_Discriminant_Constraint
+         then
+
+            declare
+               Typ : constant Entity_Id := Entity (Subtype_Mark (Subt_Indic));
+               Indic_Typ    : constant Entity_Id := Underlying_Type (Typ);
+               Subt_Index   : Node_Id;
+               Target_Index : Node_Id;
+            begin
+
+               if Present (Indic_Typ) and then Is_Array_Type (Indic_Typ) then
+
+                  Target_Index := First_Index (Indic_Typ);
+                  Subt_Index := First (Constraints (Constraint (Subt_Indic)));
+
+                  while Present (Target_Index) loop
+                     if Nkind (Subt_Index) in N_Expanded_Name | N_Identifier
+                     and then Nkind
+                        (Scalar_Range (Entity (Subt_Index))) = N_Range
+                     then
+                        Apply_Range_Check
+                           (Expr        => Scalar_Range (Entity (Subt_Index)),
+                            Target_Typ  => Etype (Target_Index),
+                            Insert_Node => Subt_Indic);
+                     end if;
+
+                     Next (Subt_Index);
+                     Next_Index (Target_Index);
+                  end loop;
+               end if;
+            end;
+         end if;
+      end Add_Range_Checks;
+
    --  Start of processing for Analyze_Component_Declaration
 
    begin
@@ -2224,6 +2271,9 @@ package body Sem_Ch3 is
       Analyze_Aspect_Specifications (N, Id);
 
       Analyze_Dimension (N);
+
+      Add_Range_Checks (Subtype_Indication (Component_Definition (N)));
+
    end Analyze_Component_Declaration;
 
    --------------------------
-- 
2.43.2

[COMMITTED 05/35] ada: Check subtype to avoid a precondition failure

[Marc Poulhiès]

From: Viljar Indus <indus@adacore.com>

gcc/ada/

	* sem_ch3.adb (Analyze_Component_Declaration):
	Apply range checks only for Scalar_Types to
	ensure that they have the Scalar_Range attribute.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_ch3.adb | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 7ee4ca299d9..263be607ec1 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2029,8 +2029,9 @@ package body Sem_Ch3 is
 
                   while Present (Target_Index) loop
                      if Nkind (Subt_Index) in N_Expanded_Name | N_Identifier
-                     and then Nkind
-                        (Scalar_Range (Entity (Subt_Index))) = N_Range
+                       and then Is_Scalar_Type (Entity (Subt_Index))
+                       and then
+                         Nkind (Scalar_Range (Entity (Subt_Index))) = N_Range
                      then
                         Apply_Range_Check
                            (Expr        => Scalar_Range (Entity (Subt_Index)),
-- 
2.43.2

[COMMITTED 06/35] ada: Fix probable copy/paste error

[Marc Poulhiès]

gcc/ada/

	* doc/gnat_rm/implementation_defined_attributes.rst: Fix
	copy/paste.
	* gnat_rm.texi: Regenerate.
	* gnat_ugn.texi: Regenerate.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst | 7 +++----
 gcc/ada/gnat_rm.texi                                      | 7 +++----
 gcc/ada/gnat_ugn.texi                                     | 4 ++--
 3 files changed, 8 insertions(+), 10 deletions(-)

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index f8700b1be4e..728d63a8e92 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -81,10 +81,9 @@ Attribute Atomic_Always_Lock_Free
 =================================
 .. index:: Atomic_Always_Lock_Free
 
-The prefix of the ``Atomic_Always_Lock_Free`` attribute is a type.
-The result is a Boolean value which is True if the type has discriminants,
-and False otherwise.  The result indicate whether atomic operations are
-supported by the target for the given type.
+The prefix of the ``Atomic_Always_Lock_Free`` attribute is a type. The
+result indicates whether atomic operations are supported by the target
+for the given type.
 
 Attribute Bit
 =============
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 6da3f3131d5..8dcdd6ca14c 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -10373,10 +10373,9 @@ either be omitted, or explicitly given as @code{No_Output_Operands}.
 
 @geindex Atomic_Always_Lock_Free
 
-The prefix of the @code{Atomic_Always_Lock_Free} attribute is a type.
-The result is a Boolean value which is True if the type has discriminants,
-and False otherwise.  The result indicate whether atomic operations are
-supported by the target for the given type.
+The prefix of the @code{Atomic_Always_Lock_Free} attribute is a type. The
+result indicates whether atomic operations are supported by the target
+for the given type.
 
 @node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes
 @anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{178}
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 997086c67bd..7bad8b4e161 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT User's Guide for Native Platforms , Apr 15, 2024
+GNAT User's Guide for Native Platforms , Apr 16, 2024
 
 AdaCore
 
@@ -29580,8 +29580,8 @@ to permit their use in free software.
 
 @printindex ge
 
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{                              }
 @anchor{d1}@w{                              }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{                              }
 
 @c %**end of body
 @bye
-- 
2.43.2

[COMMITTED 07/35] ada: Tune detection of unconstrained and tagged items in Depends contract

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

The Tagged/Array/Record/Private types are mutually exclusive, so they
can be examined like with a case statement (except for records with
private extensions, but their handling is not affected by this change).

gcc/ada/

	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): Tune repeated
	testing of type kinds.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_prag.adb | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 2fc46ab0cd2..9dc22e3edc1 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -32970,14 +32970,14 @@ package body Sem_Prag is
       if Is_Tagged_Type (Typ) then
          return True;
 
-      elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
-         return True;
+      elsif Is_Array_Type (Typ) then
+         return not Is_Constrained (Typ);
 
       elsif Is_Record_Type (Typ) then
          return Has_Discriminants (Typ) and then not Is_Constrained (Typ);
 
-      elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
-         return True;
+      elsif Is_Private_Type (Typ) then
+         return Has_Discriminants (Typ);
 
       else
          return False;
-- 
2.43.2

[COMMITTED 08/35] ada: Allow private items with unknown discriminants as Depends inputs

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

Objects of private types with unknown discriminants are now allowed as
inputs in the Depends contracts.

gcc/ada/

	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): Allow objects
	of private types with unknown discriminants.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_prag.adb | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 9dc22e3edc1..0302cdb00ba 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -283,7 +283,8 @@ package body Sem_Prag is
    function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
    --  Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
    --  pragma Depends. Determine whether the type of dependency item Item is
-   --  tagged, unconstrained array or unconstrained record.
+   --  tagged, unconstrained array, unconstrained private or unconstrained
+   --  record.
 
    procedure Record_Possible_Body_Reference
      (State_Id : Entity_Id;
@@ -32977,7 +32978,8 @@ package body Sem_Prag is
          return Has_Discriminants (Typ) and then not Is_Constrained (Typ);
 
       elsif Is_Private_Type (Typ) then
-         return Has_Discriminants (Typ);
+         return Has_Discriminants (Typ)
+           or else Has_Unknown_Discriminants (Typ);
 
       else
          return False;
-- 
2.43.2

[COMMITTED 09/35] ada: Simplify code for private types with unknown discriminants

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

Private type entities have Is_Constrained set when they have no
discriminants and no unknown discriminants; it is now set slightly
later, but simpler (this change could only affect Process_Discriminants,
but this flag should not be needed there).

Also, we now reuse this flag to detect private types with discriminants.

Code cleanup; behavior is unaffected.

gcc/ada/

	* sem_ch7.adb (New_Private_Type): Simplify setting of
	Is_Constrained flag.
	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): Simplify
	detection of private types with no discriminant.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_ch7.adb  | 7 +++----
 gcc/ada/sem_prag.adb | 3 +--
 2 files changed, 4 insertions(+), 6 deletions(-)

diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 74646224452..a70d72c94c1 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2746,10 +2746,6 @@ package body Sem_Ch7 is
       Set_Is_First_Subtype (Id);
       Reinit_Size_Align (Id);
 
-      Set_Is_Constrained (Id,
-        No (Discriminant_Specifications (N))
-          and then not Unknown_Discriminants_Present (N));
-
       --  Set tagged flag before processing discriminants, to catch illegal
       --  usage.
 
@@ -2765,6 +2761,9 @@ package body Sem_Ch7 is
 
       elsif Unknown_Discriminants_Present (N) then
          Set_Has_Unknown_Discriminants (Id);
+
+      else
+         Set_Is_Constrained (Id);
       end if;
 
       Set_Private_Dependents (Id, New_Elmt_List);
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0302cdb00ba..e57f42d9a54 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -32978,8 +32978,7 @@ package body Sem_Prag is
          return Has_Discriminants (Typ) and then not Is_Constrained (Typ);
 
       elsif Is_Private_Type (Typ) then
-         return Has_Discriminants (Typ)
-           or else Has_Unknown_Discriminants (Typ);
+         return not Is_Constrained (Typ);
 
       else
          return False;
-- 
2.43.2

[COMMITTED 10/35] ada: Only record types with discriminants can be unconstrained

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

Remove redundant condition for detecting unconstrained record types.

Code cleanup; behavior is unaffected.

gcc/ada/

	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): Remove call
	to Has_Discriminants; combine ELSIF branches.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_prag.adb | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index e57f42d9a54..02aad4d1caa 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -32971,13 +32971,10 @@ package body Sem_Prag is
       if Is_Tagged_Type (Typ) then
          return True;
 
-      elsif Is_Array_Type (Typ) then
-         return not Is_Constrained (Typ);
-
-      elsif Is_Record_Type (Typ) then
-         return Has_Discriminants (Typ) and then not Is_Constrained (Typ);
-
-      elsif Is_Private_Type (Typ) then
+      elsif Is_Array_Type (Typ)
+        or else Is_Record_Type (Typ)
+        or else Is_Private_Type (Typ)
+      then
          return not Is_Constrained (Typ);
 
       else
-- 
2.43.2

[COMMITTED 11/35] ada: Fix Constraint_Error on mutable assignment

[Marc Poulhiès]

From: Bob Duff <duff@adacore.com>

For an assignment statement "X := Y;", where X is a formal parameter
of a "late overriding" subprogram (i.e. it has no spec, and the body
is overriding), and the subtype of X is an unconstrained record with
defaulted discriminants, if the actual parameter passed to X is
unconstrained, then X is unconstrained. This patch fixes a bug
where X was incorrectly considered constrained, so that if Y's
discriminants are different from X, Constraint_Error was raised.

The bug was caused by the fact that an extra "constrained" formal
parameter was missing in both caller and callee.

gcc/ada/

	* sem_disp.adb (Check_Dispatching_Operation): Call
	Create_Extra_Formals, so that the caller will have an extra
	"constrained" parameter, which will be checked on assignment in
	the callee, and will be passed in by the caller.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_disp.adb | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 525a9f7f0a1..fd521a09bc0 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1514,10 +1514,10 @@ package body Sem_Disp is
                         Subp);
 
                   else
-
                      --  The subprogram body declares a primitive operation.
                      --  We must update its dispatching information here. The
                      --  information is taken from the overridden subprogram.
+                     --  Such a late-overriding body also needs extra formals.
                      --  We must also generate a cross-reference entry because
                      --  references to other primitives were already created
                      --  when type was frozen.
@@ -1527,6 +1527,7 @@ package body Sem_Disp is
                      if Present (DTC_Entity (Old_Subp)) then
                         Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
                         Set_DT_Position_Value (Subp, DT_Position (Old_Subp));
+                        Create_Extra_Formals (Subp);
 
                         if not Restriction_Active (No_Dispatching_Calls) then
                            if Building_Static_DT (Tagged_Type) then
-- 
2.43.2

[COMMITTED 12/35] ada: Fix crash caused by missing New_Copy_tree

[Marc Poulhiès]

Since a recent refactor ("Factor common processing in expansion of
aggregates") where Initialize_Array_Component and
Initialize_Record_Component are merged, the behavior has slightly
changed. In the case of the expansion of an aggregate initialization
where the number of 'others' components is <= 3, the initialization
expression is not duplicated anymore, causing some incorrect multiple
definition when said expression is later transformed with
Expressions_With_Action that declares an object. The simple fix is to
add the now missing New_Copy_Tree where the assignments are created.

gcc/ada/

	* exp_aggr.adb (Build_Array_Aggr_Code) <Gen_Loop>: Copy the
	initialization expression when unrolling the loop.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_aggr.adb | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index cff04fc1b79..9c5944a917d 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1649,11 +1649,14 @@ package body Exp_Aggr is
            and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
            and then not Is_Iterated_Component
          then
-            Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
-            Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
+            Append_List_To
+              (S, Gen_Assign (New_Copy_Tree (L), New_Copy_Tree (Expr)));
+            Append_List_To
+              (S, Gen_Assign (Add (1, To => L), New_Copy_Tree (Expr)));
 
             if Local_Expr_Value (H) - Local_Expr_Value (L) = 2 then
-               Append_List_To (S, Gen_Assign (Add (2, To => L), Expr));
+               Append_List_To
+                 (S, Gen_Assign (Add (2, To => L), New_Copy_Tree (Expr)));
             end if;
 
             return S;
-- 
2.43.2

[COMMITTED 13/35] ada: Make raise-gcc.c compatible with Clang

[Marc Poulhiès]

From: Sebastian Poeplau <poeplau@adacore.com>

The Morello variant of Clang doesn't have
__builtin_code_address_from_pointer; work around it where necessary.

gcc/ada/

	* raise-gcc.c: Work around __builtin_code_address_from_pointer
	if it is unavailable.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/raise-gcc.c | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
index 01cf4b6236d..7179f62529e 100644
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -596,7 +596,15 @@ get_ip_from_context (_Unwind_Context *uw_context)
 #endif
 
 #if !defined(__USING_SJLJ_EXCEPTIONS__) && defined(__CHERI__)
+#if __has_builtin (__builtin_code_address_from_pointer)
   ip = __builtin_code_address_from_pointer ((void *)ip);
+#elif defined(__aarch64__)
+  /* Clang doesn't have __builtin_code_address_from_pointer to abstract over
+     target-specific differences. On AArch64, we need to drop the LSB of the
+     instruction pointer because it's not part of the address; it indicates the
+     CPU mode. */
+  ip &= ~1UL;
+#endif
 #endif
 
   /* Subtract 1 if necessary because GetIPInfo yields a call return address
-- 
2.43.2

[COMMITTED 14/35] ada: gnatbind-related cleanups

[Marc Poulhiès]

From: Bob Duff <duff@adacore.com>

This patch cleans up some things noticed while working on gnatbind.
No change in behavior yet.

gcc/ada/

	* ali-util.adb (Read_Withed_ALIs): Minor reformatting.
	* bindo-units.adb (Corresponding_Body): Add assert.
	(Corresponding_Spec): Likewise.
	* uname.adb: Clean up assertions, use available functions.
	Get_Spec_Name/Get_Body_Name can assert that N obeys the
	conventions for Unit_Name_Type (end in "%s" or "%b").

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/ali-util.adb    |  4 +--
 gcc/ada/bindo-units.adb |  8 ++++--
 gcc/ada/uname.adb       | 61 ++++++++++++++---------------------------
 3 files changed, 28 insertions(+), 45 deletions(-)

diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
index fe0af74086c..61dddb94e85 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -161,9 +161,7 @@ package body ALI.Util is
       --  Process all dependent units
 
       for U in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop
-         for
-           W in Units.Table (U).First_With .. Units.Table (U).Last_With
-         loop
+         for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
             Afile := Withs.Table (W).Afile;
 
             --  Only process if not a generic (Afile /= No_File) and if
diff --git a/gcc/ada/bindo-units.adb b/gcc/ada/bindo-units.adb
index 0fbe8e9d381..0acc6612270 100644
--- a/gcc/ada/bindo-units.adb
+++ b/gcc/ada/bindo-units.adb
@@ -103,7 +103,9 @@ package body Bindo.Units is
 
    begin
       pragma Assert (U_Rec.Utype = Is_Spec);
-      return U_Id - 1;
+      return Result : constant Unit_Id := U_Id - 1 do
+         pragma Assert (ALI.Units.Table (Result).Utype = Is_Body);
+      end return;
    end Corresponding_Body;
 
    ------------------------
@@ -117,7 +119,9 @@ package body Bindo.Units is
 
    begin
       pragma Assert (U_Rec.Utype = Is_Body);
-      return U_Id + 1;
+      return Result : constant Unit_Id := U_Id + 1 do
+         pragma Assert (ALI.Units.Table (Result).Utype = Is_Spec);
+      end return;
    end Corresponding_Spec;
 
    ------------------------
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index 08574784173..dbb08b88cfd 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -50,14 +50,8 @@ package body Uname is
       Buffer : Bounded_String;
    begin
       Append (Buffer, N);
-
-      pragma Assert
-        (Buffer.Length > 2
-         and then Buffer.Chars (Buffer.Length - 1) = '%'
-         and then Buffer.Chars (Buffer.Length) = 's');
-
+      pragma Assert (Is_Spec_Name (N));
       Buffer.Chars (Buffer.Length) := 'b';
-
       return Name_Find (Buffer);
    end Get_Body_Name;
 
@@ -160,14 +154,8 @@ package body Uname is
       Buffer : Bounded_String;
    begin
       Append (Buffer, N);
-
-      pragma Assert
-        (Buffer.Length > 2
-         and then Buffer.Chars (Buffer.Length - 1) = '%'
-         and then Buffer.Chars (Buffer.Length) = 'b');
-
+      pragma Assert (Is_Body_Name (N));
       Buffer.Chars (Buffer.Length) := 's';
-
       return Name_Find (Buffer);
    end Get_Spec_Name;
 
@@ -416,6 +404,9 @@ package body Uname is
       Suffix : Boolean := True)
    is
    begin
+      pragma Assert (Buf.Chars (1) /= '"');
+      pragma Assert (Is_Body_Name (N) or else Is_Spec_Name (N));
+
       Buf.Length := 0;
       Append_Decoded (Buf, N);
 
@@ -424,17 +415,11 @@ package body Uname is
       --  (lower case) 's'/'b', and before appending (lower case) "spec" or
       --  "body".
 
-      pragma Assert (Buf.Length >= 3);
-      pragma Assert (Buf.Chars (1) /= '"');
-      pragma Assert (Buf.Chars (Buf.Length) in 's' | 'b');
-
       declare
          S : constant String :=
            (if Buf.Chars (Buf.Length) = 's' then " (spec)" else " (body)");
       begin
-         Buf.Length := Buf.Length - 1; -- remove 's' or 'b'
-         pragma Assert (Buf.Chars (Buf.Length) = '%');
-         Buf.Length := Buf.Length - 1; -- remove '%'
+         Buf.Length := Buf.Length - 2; -- remove "%s" or "%b"
          Set_Casing (Buf, Identifier_Casing (Source_Index (Main_Unit)));
 
          if Suffix then
@@ -474,9 +459,9 @@ package body Uname is
       Buffer : Bounded_String;
    begin
       Append (Buffer, N);
-      return Buffer.Length > 2
-        and then Buffer.Chars (Buffer.Length - 1) = '%'
-        and then Buffer.Chars (Buffer.Length) = 'b';
+      pragma Assert
+        (Buffer.Length > 2 and then Buffer.Chars (Buffer.Length - 1) = '%');
+      return Buffer.Chars (Buffer.Length) = 'b';
    end Is_Body_Name;
 
    -------------------
@@ -535,10 +520,7 @@ package body Uname is
       System     : constant String := "system";
 
    begin
-      if Name = Ada
-        or else Name = Interfaces
-        or else Name = System
-      then
+      if Name in Ada | Interfaces | System then
          return True;
       end if;
 
@@ -555,15 +537,14 @@ package body Uname is
 
       --  The following are the predefined renamings
 
-      return
-        Name = "calendar"
-          or else Name = "machine_code"
-          or else Name = "unchecked_conversion"
-          or else Name = "unchecked_deallocation"
-          or else Name = "direct_io"
-          or else Name = "io_exceptions"
-          or else Name = "sequential_io"
-          or else Name = "text_io";
+      return Name in "calendar"
+        | "machine_code"
+        | "unchecked_conversion"
+        | "unchecked_deallocation"
+        | "direct_io"
+        | "io_exceptions"
+        | "sequential_io"
+        | "text_io";
    end Is_Predefined_Unit_Name;
 
    ------------------
@@ -574,9 +555,9 @@ package body Uname is
       Buffer : Bounded_String;
    begin
       Append (Buffer, N);
-      return Buffer.Length > 2
-        and then Buffer.Chars (Buffer.Length - 1) = '%'
-        and then Buffer.Chars (Buffer.Length) = 's';
+      pragma Assert
+        (Buffer.Length > 2 and then Buffer.Chars (Buffer.Length - 1) = '%');
+      return Buffer.Chars (Buffer.Length) = 's';
    end Is_Spec_Name;
 
    -----------------------
-- 
2.43.2

[COMMITTED 15/35] ada: correction to gnatbind-related cleanups

[Marc Poulhiès]

From: Bob Duff <duff@adacore.com>

Correction to previous change; Asserts had been moved to
before Buf was initialized.

gcc/ada/

	* uname.adb (Get_Unit_Name_String): Move Asserts after
	Buf is initialized.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/uname.adb | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index dbb08b88cfd..5a7dac53b3d 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -404,11 +404,10 @@ package body Uname is
       Suffix : Boolean := True)
    is
    begin
-      pragma Assert (Buf.Chars (1) /= '"');
-      pragma Assert (Is_Body_Name (N) or else Is_Spec_Name (N));
-
       Buf.Length := 0;
       Append_Decoded (Buf, N);
+      pragma Assert (Buf.Chars (1) /= '"');
+      pragma Assert (Is_Body_Name (N) or else Is_Spec_Name (N));
 
       --  Buf always ends with "%s" or "%b", which we either remove, or replace
       --  with " (spec)" or " (body)". Set_Casing of Buf after checking for
-- 
2.43.2

[COMMITTED 16/35] ada: Fix containers' Reference_Preserving_Key functions' memory leaks

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

Fix memory leaks in containers' Reference_Preserving_Key functions

Make the same change in each of 3 Ada.Containers child units: Ordered_Sets,
Indefinite_Ordered_Sets, and Bounded_Ordered_Sets. The function
Reference_Preserving_Key evaluates an allocator of type Key_Access whose
storage was not being reclaimed. Update the Finalize procedure for
type Reference_Control_Type to free that storage. But this change introduces
a possible erroneous double-free situation if an object is copied (because
the original and the copy will each be finalized at some point). So also
introduce an Adjust procedure which allocates a copy of the allocated object.
Another possible solution to this problem (which is not being implemented
yet) is based on implementing AI22-0082. Also include a fix for a bug in
Sem_Util.Has_Some_Controlled_Component that was discovered while working
on this.

gcc/ada/

	* sem_util.adb (Has_Some_Controlled_Component): Fix a bug which
	causes (in some cases involving a Disable_Controlled aspect
	specification) Needs_Finalization to return different answers for
	one type depending on whether the function is called before or
	after the type is frozen.
	* libgnat/a-coorse.ads: Type Control_Reference_Type gets an Adjust
	procedure.
	* libgnat/a-cborse.ads: Likewise.
	* libgnat/a-ciorse.ads: Likewise
	* libgnat/a-coorse.adb:
	(Finalize): Reclaim allocated Key_Type object.
	(Adjust): New procedure; prevent sharing of non-null Key_Access
	values by allocating a copy.
	* libgnat/a-cborse.adb: Likewise.
	* libgnat/a-ciorse.adb: Likewise.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/libgnat/a-cborse.adb | 17 +++++++++++++++++
 gcc/ada/libgnat/a-cborse.ads |  3 +++
 gcc/ada/libgnat/a-ciorse.adb | 16 +++++++++++++++-
 gcc/ada/libgnat/a-ciorse.ads |  3 +++
 gcc/ada/libgnat/a-coorse.adb | 16 +++++++++++++++-
 gcc/ada/libgnat/a-coorse.ads |  3 +++
 gcc/ada/sem_util.adb         |  6 +++++-
 7 files changed, 61 insertions(+), 3 deletions(-)

diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index b649c5eb6e7..9d2a0216342 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -40,6 +40,8 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
 pragma Elaborate_All
   (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
 
+with Ada.Unchecked_Deallocation;
+
 with System; use type System.Address;
 with System.Put_Images;
 
@@ -775,6 +777,18 @@ is
            Is_Less_Key_Node    => Is_Less_Key_Node,
            Is_Greater_Key_Node => Is_Greater_Key_Node);
 
+      ------------
+      -- Adjust --
+      ------------
+
+      procedure Adjust (Control : in out Reference_Control_Type) is
+      begin
+         Impl.Reference_Control_Type (Control).Adjust;
+         if Control.Old_Key /= null then
+            Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+         end if;
+      end Adjust;
+
       -------------
       -- Ceiling --
       -------------
@@ -872,6 +886,8 @@ is
       --------------
 
       procedure Finalize (Control : in out Reference_Control_Type) is
+         procedure Deallocate is
+           new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
       begin
          if Control.Container /= null then
             Impl.Reference_Control_Type (Control).Finalize;
@@ -883,6 +899,7 @@ is
             end if;
 
             Control.Container := null;
+            Deallocate (Control.Old_Key);
          end if;
       end Finalize;
 
diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
index 2366d1adcc2..650f4a40384 100644
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -324,6 +324,9 @@ is
          Old_Key   : Key_Access;
       end record;
 
+      overriding procedure Adjust (Control : in out Reference_Control_Type);
+      pragma Inline (Adjust);
+
       overriding procedure Finalize (Control : in out Reference_Control_Type);
       pragma Inline (Finalize);
 
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index d90fb882b43..fe91345cdd4 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -807,6 +807,18 @@ is
            Is_Less_Key_Node    => Is_Less_Key_Node,
            Is_Greater_Key_Node => Is_Greater_Key_Node);
 
+      ------------
+      -- Adjust --
+      ------------
+
+      procedure Adjust (Control : in out Reference_Control_Type) is
+      begin
+         Impl.Reference_Control_Type (Control).Adjust;
+         if Control.Old_Key /= null then
+            Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+         end if;
+      end Adjust;
+
       -------------
       -- Ceiling --
       -------------
@@ -906,6 +918,8 @@ is
       --------------
 
       procedure Finalize (Control : in out Reference_Control_Type) is
+         procedure Deallocate is
+           new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
       begin
          if Control.Container /= null then
             Impl.Reference_Control_Type (Control).Finalize;
@@ -917,7 +931,7 @@ is
             end if;
 
             Control.Container := null;
-            Control.Old_Key   := null;
+            Deallocate (Control.Old_Key);
          end if;
       end Finalize;
 
diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
index a8a87cdab3e..5bc9800b5d1 100644
--- a/gcc/ada/libgnat/a-ciorse.ads
+++ b/gcc/ada/libgnat/a-ciorse.ads
@@ -338,6 +338,9 @@ is
          Old_Key   : Key_Access;
       end record;
 
+      overriding procedure Adjust (Control : in out Reference_Control_Type);
+      pragma Inline (Adjust);
+
       overriding procedure Finalize (Control : in out Reference_Control_Type);
       pragma Inline (Finalize);
 
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index ca97fa4e620..a324b54fbef 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -729,6 +729,18 @@ is
            Is_Less_Key_Node    => Is_Less_Key_Node,
            Is_Greater_Key_Node => Is_Greater_Key_Node);
 
+      ------------
+      -- Adjust --
+      ------------
+
+      procedure Adjust (Control : in out Reference_Control_Type) is
+      begin
+         Impl.Reference_Control_Type (Control).Adjust;
+         if Control.Old_Key /= null then
+            Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+         end if;
+      end Adjust;
+
       -------------
       -- Ceiling --
       -------------
@@ -825,6 +837,8 @@ is
       --------------
 
       procedure Finalize (Control : in out Reference_Control_Type) is
+         procedure Deallocate is
+           new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
       begin
          if Control.Container /= null then
             Impl.Reference_Control_Type (Control).Finalize;
@@ -836,7 +850,7 @@ is
             end if;
 
             Control.Container := null;
-            Control.Old_Key   := null;
+            Deallocate (Control.Old_Key);
          end if;
       end Finalize;
 
diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 14708752a83..ab83e1abe43 100644
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -323,6 +323,9 @@ is
          Old_Key   : Key_Access;
       end record;
 
+      overriding procedure Adjust (Control : in out Reference_Control_Type);
+      pragma Inline (Adjust);
+
       overriding procedure Finalize (Control : in out Reference_Control_Type);
       pragma Inline (Finalize);
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 01fed402256..dd9f868b696 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -22220,7 +22220,11 @@ package body Sem_Util is
             elsif Is_Record_Type (Input_Typ) then
                Comp := First_Component (Input_Typ);
                while Present (Comp) loop
-                  if Needs_Finalization (Etype (Comp)) then
+                  --  Skip _Parent component like Expand_Freeze_Record_Type
+
+                  if Chars (Comp) /= Name_uParent
+                    and then Needs_Finalization (Etype (Comp))
+                  then
                      return True;
                   end if;
 
-- 
2.43.2

[COMMITTED 17/35] ada: Update docs for Resolve_Null_Array_Aggregate

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

The documentation comments for Sem_Aggr.Resolve_Null_Array_Aggregate
suggested that this subprogram created a subtype, which it didn't.
This patch replaces those comments with ones that better match the
behavior.

gcc/ada/

	* sem_aggr.adb (Resolve_Null_Array_Aggregate): Update
	documentation comments.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_aggr.adb | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 508c86bc5de..64e7db79ecc 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -409,11 +409,10 @@ package body Sem_Aggr is
    --  string as an aggregate, prior to resolution.
 
    function Resolve_Null_Array_Aggregate (N : Node_Id) return Boolean;
-   --  For the Ada 2022 construct, build a subtype with a null range for each
-   --  dimension, using the bounds from the context subtype (if the subtype
-   --  is constrained). If the subtype is unconstrained, then the bounds
-   --  are determined in much the same way as the bounds for a null string
-   --  literal with no applicable index constraint.
+   --  The recursive method used to construct an aggregate's bounds in
+   --  Resolve_Array_Aggregate cannot work for null array aggregates. This
+   --  function constructs an appropriate list of ranges and stores its first
+   --  element in Aggregate_Bounds (N).
 
    ---------------------------------
    --  Delta aggregate processing --
@@ -4540,7 +4539,8 @@ package body Sem_Aggr is
 
       Set_Parent (Constr, N);
 
-      --  Create a constrained subtype with null dimensions
+      --  Populate the list with null ranges. The relevant RM clauses are
+      --  RM 4.3.3 (26.1) and RM 4.3.3 (26).
 
       Index := First_Index (Typ);
       while Present (Index) loop
-- 
2.43.2

[COMMITTED 18/35] ada: gnatbind: subprogram spec no longer exists

[Marc Poulhiès]

From: Bob Duff <duff@adacore.com>

If a subprogram spec S is present while compiling something that
says "with S;", but the spec is absent while compiling the body
of S, then gnatbind fails to detect the mismatch.  The spec and
body of S might have different parameter and result types.
This patch fixes gnatbind to detect this case and give an error.

gcc/ada/

	* bcheck.adb (Check_Consistency_Of_Sdep): Split out new procedure.
	Add check for special case of subprogram spec that no longer
	exists.
	(Check_Consistency): Call Check_Consistency_Of_Sdep, except when
	Reified_Child_Spec is True. No need for "goto Continue" or "exit
	Sdep_Loop".
	* ali.ads (Subunit_Name, Unit_Name): Change the type to
	Unit_Name_Type. Add a comment pointing to the ALI file
	documentation, because it's in a somewhat-surprising place.
	* ali.adb (Scan_ALI): Subunit_Name and Unit_Name are now
	Unit_Name_Type. Remove comment explaining why Name_Find is used;
	Name_Find is the usual case. Do not remove the "%s" or "%b" from
	the Unit_Name. We need to be able to distinguish specs and bodies.
	This is also necessary to obey the invariant of Unit_Name_Type.
	* binde.adb (Write_Closure): Subunit_Name is now Unit_Name_Type.
	* clean.adb (Clean_Executables): Likewise.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/ali.adb    |   9 +-
 gcc/ada/ali.ads    |  10 +--
 gcc/ada/bcheck.adb | 216 +++++++++++++++++++++++++++------------------
 gcc/ada/binde.adb  |   2 +-
 gcc/ada/clean.adb  |   2 +-
 5 files changed, 141 insertions(+), 98 deletions(-)

diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 6bf48c04afe..69a91bce5ab 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -3287,8 +3287,8 @@ package body ALI is
 
             --  Acquire (sub)unit and reference file name entries
 
-            Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
-            Sdep.Table (Sdep.Last).Unit_Name    := No_Name;
+            Sdep.Table (Sdep.Last).Subunit_Name := No_Unit_Name;
+            Sdep.Table (Sdep.Last).Unit_Name    := No_Unit_Name;
             Sdep.Table (Sdep.Last).Rfile        :=
               Sdep.Table (Sdep.Last).Sfile;
             Sdep.Table (Sdep.Last).Start_Line   := 1;
@@ -3304,16 +3304,13 @@ package body ALI is
                      Add_Char_To_Name_Buffer (Getc);
                   end loop;
 
-                  --  Set the (sub)unit name. Note that we use Name_Find rather
-                  --  than Name_Enter here as the subunit name may already
-                  --  have been put in the name table by the Project Manager.
+                  --  Set the (sub)unit name.
 
                   if Name_Len <= 2
                     or else Name_Buffer (Name_Len - 1) /= '%'
                   then
                      Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
                   else
-                     Name_Len := Name_Len - 2;
                      Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
                   end if;
 
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 67b8fcd1b80..1f452268681 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -25,7 +25,7 @@
 
 --  This package defines the internal data structures used for representation
 --  of Ada Library Information (ALI) acquired from the ALI files generated by
---  the front end.
+--  the front end. The format of the ALI files is documented in Lib.Writ.
 
 with Casing;  use Casing;
 with Gnatvsn; use Gnatvsn;
@@ -882,11 +882,11 @@ package ALI is
       --  Set True for dummy entries that correspond to missing files or files
       --  where no dependency relationship exists.
 
-      Subunit_Name : Name_Id;
-      --  Name_Id for subunit name if present, else No_Name
+      Subunit_Name : Unit_Name_Type;
+      --  Subunit name if present, else No_Unit_Name
 
-      Unit_Name : Name_Id;
-      --  Name_Id for the unit name if not a subunit (No_Name for a subunit)
+      Unit_Name : Unit_Name_Type;
+      --  Unit name if not a subunit (No_Unit_Name for a subunit)
 
       Rfile : File_Name_Type;
       --  Reference file name. Same as Sfile unless a Source_Reference pragma
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index dd2ece80d01..56a417cc517 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -36,6 +36,7 @@ with Osint;
 with Output;   use Output;
 with Rident;   use Rident;
 with Types;    use Types;
+with Uname;
 
 package body Bcheck is
 
@@ -68,6 +69,12 @@ package body Bcheck is
    --  Used to compare two unit names for No_Dependence checks. U1 is in
    --  standard unit name format, and U2 is in literal form with periods.
 
+   procedure Check_Consistency_Of_Sdep
+     (A : ALIs_Record; D : Sdep_Record; Src : Source_Record);
+   --  Called by Check_Consistency to check the consistency of one Sdep record,
+   --  where A is the ALI, and D represents the unit it depends on, and Src is
+   --  the source file corresponding to D.
+
    -------------------------------------
    -- Check_Configuration_Consistency --
    -------------------------------------
@@ -107,15 +114,129 @@ package body Bcheck is
       Check_Consistent_Dispatching_Policy;
    end Check_Configuration_Consistency;
 
+   -------------------------------
+   -- Check_Consistency_Of_Sdep --
+   -------------------------------
+
+   procedure Check_Consistency_Of_Sdep
+     (A : ALIs_Record; D : Sdep_Record; Src : Source_Record)
+   is
+      use Uname;
+      ALI_Path_Id : File_Name_Type;
+   begin
+      --  Check for special case of withing a unit that does not exist any
+      --  more. If the unit was completely missing we would already have
+      --  detected this, but a nasty case arises when we have a subprogram body
+      --  with no spec, and some obsolete unit with's a previous (now
+      --  disappeared) spec. We detect this nasty case by noticing we're
+      --  depending on a spec that has no corresponding unit table entry,
+      --  but the body does.
+
+      if Present (D.Unit_Name)
+        and then Is_Spec_Name (D.Unit_Name)
+        and then Get_Name_Table_Int (D.Unit_Name) = 0 -- no unit table entry?
+        and then Get_Name_Table_Int (Get_Body_Name (D.Unit_Name)) /= 0
+      then
+         Error_Msg_File_1 := A.Sfile;
+         Error_Msg_Unit_1 := D.Unit_Name;
+         Error_Msg ("{ depends on $ which no longer exists");
+      end if;
+
+      --  Now if the time stamps match, or all checksums match, then we are OK;
+      --  otherwise we have an error.
+
+      if D.Stamp /= Src.Stamp and then not Src.All_Checksums_Match then
+         Error_Msg_File_1 := A.Sfile;
+         Error_Msg_File_2 := D.Sfile;
+
+         --  Two styles of message, depending on whether or not
+         --  the updated file is the one that must be recompiled
+
+         if Error_Msg_File_1 = Error_Msg_File_2 then
+            if Tolerate_Consistency_Errors then
+               Error_Msg
+                  ("?{ has been modified and should be recompiled");
+            else
+               Error_Msg
+                 ("{ has been modified and must be recompiled");
+            end if;
+
+         else
+            ALI_Path_Id :=
+              Osint.Full_Lib_File_Name (A.Afile);
+
+            if Osint.Is_Readonly_Library (ALI_Path_Id) then
+               if Tolerate_Consistency_Errors then
+                  Error_Msg ("?{ should be recompiled");
+                  Error_Msg_File_1 := ALI_Path_Id;
+                  Error_Msg ("?({ is obsolete and read-only)");
+               else
+                  Error_Msg ("{ must be compiled");
+                  Error_Msg_File_1 := ALI_Path_Id;
+                  Error_Msg ("({ is obsolete and read-only)");
+               end if;
+
+            elsif Tolerate_Consistency_Errors then
+               Error_Msg
+                 ("?{ should be recompiled ({ has been modified)");
+
+            else
+               Error_Msg ("{ must be recompiled ({ has been modified)");
+            end if;
+         end if;
+
+         if not Tolerate_Consistency_Errors and Verbose_Mode then
+            Error_Msg_File_1 := Src.Stamp_File;
+
+            if Src.Source_Found then
+               Error_Msg_File_1 :=
+                 Osint.Full_Source_Name (Error_Msg_File_1);
+            else
+               Error_Msg_File_1 :=
+                 Osint.Full_Lib_File_Name (Error_Msg_File_1);
+            end if;
+
+            Error_Msg
+              ("time stamp from { " & String (Src.Stamp));
+
+            Error_Msg_File_1 := D.Sfile;
+            Error_Msg
+              (" conflicts with { timestamp " &
+               String (D.Stamp));
+
+            Error_Msg_File_1 :=
+              Osint.Full_Lib_File_Name (A.Afile);
+            Error_Msg (" from {");
+         end if;
+      end if;
+   end Check_Consistency_Of_Sdep;
+
    -----------------------
    -- Check_Consistency --
    -----------------------
 
    procedure Check_Consistency is
-      Src : Source_Id;
-      --  Source file Id for this Sdep entry
+      function Reified_Child_Spec (A : ALI_Id; D : Sdep_Id) return Boolean;
+      --  When we have a child subprogram body with no spec, the missing spec
+      --  is reified in the ALI file. This returns True if D is a dependency on
+      --  such a reified spec. The body always immediately follows the spec
+      --  and there is no no unit table entry for the spec in this case.
+      --  We do not want to call Check_Consistency_Of_Sdep for these specs,
+      --  because it confuses the detection of (truly) missing specs.
+
+      function Reified_Child_Spec (A : ALI_Id; D : Sdep_Id) return Boolean is
+         use Uname;
+      begin
+         return Present (Sdep.Table (D).Unit_Name)
+           and then Get_Name_Table_Int (Sdep.Table (D).Unit_Name) = 0
+           and then D /= ALIs.Table (A).Last_Sdep
+           and then Sdep.Table (D).Sfile = Sdep.Table (D + 1).Sfile
+           and then Is_Spec_Name (Sdep.Table (D).Unit_Name)
+           and then Get_Body_Name (Sdep.Table (D).Unit_Name) =
+                    Sdep.Table (D + 1).Unit_Name;
+      end Reified_Child_Spec;
 
-      ALI_Path_Id : File_Name_Type;
+   --  Start of processing for Check_Consistency
 
    begin
       --  First, we go through the source table to see if there are any cases
@@ -172,89 +293,14 @@ package body Bcheck is
          Sdep_Loop : for D in
            ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep
          loop
-            if Sdep.Table (D).Dummy_Entry then
-               goto Continue;
-            end if;
-
-            Src := Source_Id (Get_Name_Table_Int (Sdep.Table (D).Sfile));
-
-            --  If the time stamps match, or all checksums match, then we
-            --  are OK, otherwise we have a definite error.
-
-            if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
-              and then not Source.Table (Src).All_Checksums_Match
+            if not Sdep.Table (D).Dummy_Entry
+              and then not Reified_Child_Spec (A, D)
             then
-               Error_Msg_File_1 := ALIs.Table (A).Sfile;
-               Error_Msg_File_2 := Sdep.Table (D).Sfile;
-
-               --  Two styles of message, depending on whether or not
-               --  the updated file is the one that must be recompiled
-
-               if Error_Msg_File_1 = Error_Msg_File_2 then
-                  if Tolerate_Consistency_Errors then
-                     Error_Msg
-                        ("?{ has been modified and should be recompiled");
-                  else
-                     Error_Msg
-                       ("{ has been modified and must be recompiled");
-                  end if;
-
-               else
-                  ALI_Path_Id :=
-                    Osint.Full_Lib_File_Name (ALIs.Table (A).Afile);
-
-                  if Osint.Is_Readonly_Library (ALI_Path_Id) then
-                     if Tolerate_Consistency_Errors then
-                        Error_Msg ("?{ should be recompiled");
-                        Error_Msg_File_1 := ALI_Path_Id;
-                        Error_Msg ("?({ is obsolete and read-only)");
-                     else
-                        Error_Msg ("{ must be compiled");
-                        Error_Msg_File_1 := ALI_Path_Id;
-                        Error_Msg ("({ is obsolete and read-only)");
-                     end if;
-
-                  elsif Tolerate_Consistency_Errors then
-                     Error_Msg
-                       ("?{ should be recompiled ({ has been modified)");
-
-                  else
-                     Error_Msg ("{ must be recompiled ({ has been modified)");
-                  end if;
-               end if;
-
-               if not Tolerate_Consistency_Errors and Verbose_Mode then
-                  Error_Msg_File_1 := Source.Table (Src).Stamp_File;
-
-                  if Source.Table (Src).Source_Found then
-                     Error_Msg_File_1 :=
-                       Osint.Full_Source_Name (Error_Msg_File_1);
-                  else
-                     Error_Msg_File_1 :=
-                       Osint.Full_Lib_File_Name (Error_Msg_File_1);
-                  end if;
-
-                  Error_Msg
-                    ("time stamp from { " & String (Source.Table (Src).Stamp));
-
-                  Error_Msg_File_1 := Sdep.Table (D).Sfile;
-                  Error_Msg
-                    (" conflicts with { timestamp " &
-                     String (Sdep.Table (D).Stamp));
-
-                  Error_Msg_File_1 :=
-                    Osint.Full_Lib_File_Name (ALIs.Table (A).Afile);
-                  Error_Msg (" from {");
-               end if;
-
-               --  Exit from the loop through Sdep entries once we find one
-               --  that does not match.
-
-               exit Sdep_Loop;
+               Check_Consistency_Of_Sdep
+                 (ALIs.Table (A), Sdep.Table (D),
+                  Source.Table
+                    (Source_Id (Get_Name_Table_Int (Sdep.Table (D).Sfile))));
             end if;
-
-         <<Continue>>
-            null;
          end loop Sdep_Loop;
       end loop ALIs_Loop;
    end Check_Consistency;
@@ -1263,7 +1309,7 @@ package body Bcheck is
    procedure Check_Duplicated_Subunits is
    begin
       for J in Sdep.First .. Sdep.Last loop
-         if Sdep.Table (J).Subunit_Name /= No_Name then
+         if Sdep.Table (J).Subunit_Name /= No_Unit_Name then
             Get_Decoded_Name_String (Sdep.Table (J).Subunit_Name);
             Name_Len := Name_Len + 2;
             Name_Buffer (Name_Len - 1) := '%';
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb
index a579e420d3b..61446274dc4 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -2334,7 +2334,7 @@ package body Binde is
       for J in Sdep.First .. Sdep.Last loop
          Source := Sdep.Table (J).Sfile;
 
-         if Sdep.Table (J).Subunit_Name /= No_Name
+         if Sdep.Table (J).Subunit_Name /= No_Unit_Name
            and then Put_In_Sources (Source)
            and then not Is_Internal_File_Name (Source)
          then
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index 925e5760570..66033623765 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -248,7 +248,7 @@ package body Clean is
                      for J in ALIs.Table (The_ALI).First_Sdep ..
                        ALIs.Table (The_ALI).Last_Sdep
                      loop
-                        if Sdep.Table (J).Subunit_Name /= No_Name then
+                        if Sdep.Table (J).Subunit_Name /= No_Unit_Name then
                            Sources.Increment_Last;
                            Sources.Table (Sources.Last) :=
                              Sdep.Table (J).Sfile;
-- 
2.43.2

[COMMITTED 19/35] ada: Couple of adjustments coming from aliasing considerations

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The first adjustment is to the expansion of implementation types for array
types with peculiar index types, for which the aliased property set on the
component of the original type must be copied; the implicit base type also
needs to be properly marked if the implementation type is constrained.

The second adjustment is to selected types in the runtime, which need to
be marked with pragma Universal_Aliasing because of their special usage.

gcc/ada/

	* exp_pakd.adb (Create_Packed_Array_Impl_Type): For non-bit-packed
	array types, propagate the aliased property of the component.
	(Install_PAT): Set fields on the implicit base type of an array.
	* libgnat/a-stream.ads (private part): Add pragma Universal_Aliasing
	for Stream_Element.
	* libgnat/g-alleve.ads: Add pragma Universal_Aliasing for all the
	vector types.
	* libgnat/g-alleve__hard.ads: Likewise.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_pakd.adb               | 12 +++++--
 gcc/ada/libgnat/a-stream.ads       |  3 ++
 gcc/ada/libgnat/g-alleve.ads       | 54 ++++++++++++++++++++++++++----
 gcc/ada/libgnat/g-alleve__hard.ads | 11 ++++++
 4 files changed, 71 insertions(+), 9 deletions(-)

diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 3f26c3527fa..59dfe5df8df 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -598,6 +598,14 @@ package body Exp_Pakd is
          Set_Associated_Node_For_Itype (PAT, Typ);
          Set_Original_Array_Type       (PAT, Typ);
 
+         --  In the case of a constrained array type, also set fields on the
+         --  implicit base type built during the analysis of its declaration.
+
+         if Ekind (PAT) = E_Array_Subtype then
+            Set_Is_Packed_Array_Impl_Type (Etype (PAT), True);
+            Set_Original_Array_Type       (Etype (PAT), Base_Type (Typ));
+         end if;
+
          --  Propagate representation aspects
 
          Set_Is_Atomic               (PAT, Is_Atomic                (Typ));
@@ -818,7 +826,7 @@ package body Exp_Pakd is
                    Subtype_Marks => Indexes,
                    Component_Definition =>
                      Make_Component_Definition (Loc,
-                       Aliased_Present    => False,
+                       Aliased_Present    => Has_Aliased_Components (Typ),
                        Subtype_Indication =>
                           New_Occurrence_Of (Ctyp, Loc)));
 
@@ -828,7 +836,7 @@ package body Exp_Pakd is
                     Discrete_Subtype_Definitions => Indexes,
                     Component_Definition =>
                       Make_Component_Definition (Loc,
-                        Aliased_Present    => False,
+                        Aliased_Present    => Has_Aliased_Components (Typ),
                         Subtype_Indication =>
                           New_Occurrence_Of (Ctyp, Loc)));
             end if;
diff --git a/gcc/ada/libgnat/a-stream.ads b/gcc/ada/libgnat/a-stream.ads
index 0a0cabce3f2..dcb5a9aa81c 100644
--- a/gcc/ada/libgnat/a-stream.ads
+++ b/gcc/ada/libgnat/a-stream.ads
@@ -84,4 +84,7 @@ private
    for Stream_Element_Array'Read use Read_SEA;
    for Stream_Element_Array'Write use Write_SEA;
 
+   pragma Universal_Aliasing (Stream_Element);
+   --  This type is used to stream any other type
+
 end Ada.Streams;
diff --git a/gcc/ada/libgnat/g-alleve.ads b/gcc/ada/libgnat/g-alleve.ads
index 0f3ec36d0f1..4e22a3e6387 100644
--- a/gcc/ada/libgnat/g-alleve.ads
+++ b/gcc/ada/libgnat/g-alleve.ads
@@ -313,22 +313,62 @@ private
    ---------------------------------------
 
    --  We simply use the natural array definitions corresponding to each
-   --  user-level vector type.
+   --  user-level vector type. We need to put pragma Universal_Aliasing
+   --  on these types because the common operations are implemented by
+   --  means of Unchecked_Conversion betwwen different representations.
 
-   type LL_VUI is new VUI_View;
-   type LL_VSI is new VSI_View;
-   type LL_VBI is new VBI_View;
+   --------------------------
+   -- char Core Components --
+   --------------------------
+
+   type LL_VUC is new VUC_View;
+   pragma Universal_Aliasing (LL_VUC);
+
+   type LL_VSC is new VSC_View;
+   pragma Universal_Aliasing (LL_VSC);
+
+   type LL_VBC is new VBC_View;
+   pragma Universal_Aliasing (LL_VBC);
+
+   ---------------------------
+   -- short Core Components --
+   ---------------------------
 
    type LL_VUS is new VUS_View;
+   pragma Universal_Aliasing (LL_VUS);
+
    type LL_VSS is new VSS_View;
+   pragma Universal_Aliasing (LL_VSS);
+
    type LL_VBS is new VBS_View;
+   pragma Universal_Aliasing (LL_VBS);
 
-   type LL_VUC is new VUC_View;
-   type LL_VSC is new VSC_View;
-   type LL_VBC is new VBC_View;
+   -------------------------
+   -- int Core Components --
+   -------------------------
+
+   type LL_VUI is new VUI_View;
+   pragma Universal_Aliasing (LL_VUI);
+
+   type LL_VSI is new VSI_View;
+   pragma Universal_Aliasing (LL_VSI);
+
+   type LL_VBI is new VBI_View;
+   pragma Universal_Aliasing (LL_VBI);
+
+   ---------------------------
+   -- Float Core Components --
+   ---------------------------
 
    type LL_VF is new VF_View;
+   pragma Universal_Aliasing (LL_VF);
+
+   ---------------------------
+   -- pixel Core Components --
+   ---------------------------
+
    type LL_VP is new VP_View;
+   pragma Universal_Aliasing (LL_VP);
 
    ------------------------------------
    -- Low level functional interface --
diff --git a/gcc/ada/libgnat/g-alleve__hard.ads b/gcc/ada/libgnat/g-alleve__hard.ads
index 5a311c7e229..88a73b38953 100644
--- a/gcc/ada/libgnat/g-alleve__hard.ads
+++ b/gcc/ada/libgnat/g-alleve__hard.ads
@@ -326,16 +326,19 @@ private
    type LL_VUC is array (1 .. 16) of unsigned_char;
    for LL_VUC'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VUC, "vector_type");
+   pragma Universal_Aliasing (LL_VUC);
    pragma Suppress (All_Checks, LL_VUC);
 
    type LL_VSC is array (1 .. 16) of signed_char;
    for LL_VSC'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VSC, "vector_type");
+   pragma Universal_Aliasing (LL_VSC);
    pragma Suppress (All_Checks, LL_VSC);
 
    type LL_VBC is array (1 .. 16) of unsigned_char;
    for LL_VBC'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VBC, "vector_type");
+   pragma Universal_Aliasing (LL_VBC);
    pragma Suppress (All_Checks, LL_VBC);
 
    ---------------------------
@@ -345,16 +348,19 @@ private
    type LL_VUS is array (1 .. 8) of unsigned_short;
    for LL_VUS'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VUS, "vector_type");
+   pragma Universal_Aliasing (LL_VUS);
    pragma Suppress (All_Checks, LL_VUS);
 
    type LL_VSS is array (1 .. 8) of signed_short;
    for LL_VSS'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VSS, "vector_type");
+   pragma Universal_Aliasing (LL_VSS);
    pragma Suppress (All_Checks, LL_VSS);
 
    type LL_VBS is array (1 .. 8) of unsigned_short;
    for LL_VBS'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VBS, "vector_type");
+   pragma Universal_Aliasing (LL_VBS);
    pragma Suppress (All_Checks, LL_VBS);
 
    -------------------------
@@ -364,16 +370,19 @@ private
    type LL_VUI is array (1 .. 4) of unsigned_int;
    for LL_VUI'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VUI, "vector_type");
+   pragma Universal_Aliasing (LL_VUI);
    pragma Suppress (All_Checks, LL_VUI);
 
    type LL_VSI is array (1 .. 4) of signed_int;
    for LL_VSI'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VSI, "vector_type");
+   pragma Universal_Aliasing (LL_VSI);
    pragma Suppress (All_Checks, LL_VSI);
 
    type LL_VBI is array (1 .. 4) of unsigned_int;
    for LL_VBI'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VBI, "vector_type");
+   pragma Universal_Aliasing (LL_VBI);
    pragma Suppress (All_Checks, LL_VBI);
 
    ---------------------------
@@ -383,6 +392,7 @@ private
    type LL_VF is array (1 .. 4) of Float;
    for LL_VF'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VF, "vector_type");
+   pragma Universal_Aliasing (LL_VF);
    pragma Suppress (All_Checks, LL_VF);
 
    ---------------------------
@@ -392,6 +402,7 @@ private
    type LL_VP is array (1 .. 8) of pixel;
    for LL_VP'Alignment use VECTOR_ALIGNMENT;
    pragma Machine_Attribute (LL_VP, "vector_type");
+   pragma Universal_Aliasing (LL_VP);
    pragma Suppress (All_Checks, LL_VP);
 
    ------------------------------------
-- 
2.43.2

[COMMITTED 20/35] ada: Expose utility routine for processing of Depends contracts in SPARK

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

Routine Is_Unconstrained_Or_Tagged_Item is now used both in the GNAT
frontend (for checking legality of Depends clauses) and in the GNATprove
backend (for representing implicit inputs in flow graphs).

gcc/ada/

	* sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): Move to
	Sem_Util, so it can be used from GNATprove.
	* sem_util.ads (Is_Unconstrained_Or_Tagged_Item): Move from
	Sem_Prag; spec.
	* sem_util.adb (Is_Unconstrained_Or_Tagged_Item): Move from
	Sem_Prag; body.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_prag.adb | 29 -----------------------------
 gcc/ada/sem_util.adb | 23 +++++++++++++++++++++++
 gcc/ada/sem_util.ads |  5 +++++
 3 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 02aad4d1caa..f27e40edcbb 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -280,12 +280,6 @@ package body Sem_Prag is
    --  Determine whether dependency clause Clause is surrounded by extra
    --  parentheses. If this is the case, issue an error message.
 
-   function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-   --  Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
-   --  pragma Depends. Determine whether the type of dependency item Item is
-   --  tagged, unconstrained array, unconstrained private or unconstrained
-   --  record.
-
    procedure Record_Possible_Body_Reference
      (State_Id : Entity_Id;
       Ref      : Node_Id);
@@ -32959,29 +32953,6 @@ package body Sem_Prag is
           and then List_Containing (N) = Private_Declarations (Parent (N));
    end Is_Private_SPARK_Mode;
 
-   -------------------------------------
-   -- Is_Unconstrained_Or_Tagged_Item --
-   -------------------------------------
-
-   function Is_Unconstrained_Or_Tagged_Item
-     (Item : Entity_Id) return Boolean
-   is
-      Typ : constant Entity_Id := Etype (Item);
-   begin
-      if Is_Tagged_Type (Typ) then
-         return True;
-
-      elsif Is_Array_Type (Typ)
-        or else Is_Record_Type (Typ)
-        or else Is_Private_Type (Typ)
-      then
-         return not Is_Constrained (Typ);
-
-      else
-         return False;
-      end if;
-   end Is_Unconstrained_Or_Tagged_Item;
-
    -----------------------------
    -- Is_Valid_Assertion_Kind --
    -----------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index dd9f868b696..be777d26e46 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -20709,6 +20709,29 @@ package body Sem_Util is
       return T = Universal_Integer or else T = Universal_Real;
    end Is_Universal_Numeric_Type;
 
+   -------------------------------------
+   -- Is_Unconstrained_Or_Tagged_Item --
+   -------------------------------------
+
+   function Is_Unconstrained_Or_Tagged_Item
+     (Item : Entity_Id) return Boolean
+   is
+      Typ : constant Entity_Id := Etype (Item);
+   begin
+      if Is_Tagged_Type (Typ) then
+         return True;
+
+      elsif Is_Array_Type (Typ)
+        or else Is_Record_Type (Typ)
+        or else Is_Private_Type (Typ)
+      then
+         return not Is_Constrained (Typ);
+
+      else
+         return False;
+      end if;
+   end Is_Unconstrained_Or_Tagged_Item;
+
    ------------------------------
    -- Is_User_Defined_Equality --
    ------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 99c60ddf708..4fef8966380 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2397,6 +2397,11 @@ package Sem_Util is
    pragma Inline (Is_Universal_Numeric_Type);
    --  True if T is Universal_Integer or Universal_Real
 
+   function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
+   --  Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
+   --  pragma Depends. Determine whether the type of dependency item Item is
+   --  tagged, unconstrained array or unconstrained record.
+
    function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
    --  Determine whether an entity denotes a user-defined equality
 
-- 
2.43.2

[COMMITTED 21/35] ada: Fix others error message location

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

Before this patch, the compiler pointed at the wrong component
association when reporting an illegal occurrence of "others" in an
aggregate. This patch fixes this by keeping track of which choice
contains the occurrence of "others" when resolving array aggregates.

gcc/ada/

	* sem_aggr.adb (Resolve_Array_Aggregate): Fix location of error
	message.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_aggr.adb | 43 +++++++++++++++++++------------------------
 1 file changed, 19 insertions(+), 24 deletions(-)

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 64e7db79ecc..ee9beb04c9a 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1335,7 +1335,7 @@ package body Sem_Aggr is
       Index_Base_High : constant Node_Id   := Type_High_Bound (Index_Base);
       --  Ditto for the base type
 
-      Others_Present : Boolean := False;
+      Others_N : Node_Id := Empty;
 
       Nb_Choices : Nat := 0;
       --  Contains the overall number of named choices in this sub-aggregate
@@ -1870,7 +1870,7 @@ package body Sem_Aggr is
 
             while Present (Choice) loop
                if Nkind (Choice) = N_Others_Choice then
-                  Others_Present := True;
+                  Others_N := Choice;
 
                else
                   Analyze (Choice);
@@ -2189,7 +2189,7 @@ package body Sem_Aggr is
             Delete_Choice := False;
             while Present (Choice) loop
                if Nkind (Choice) = N_Others_Choice then
-                  Others_Present := True;
+                  Others_N := Choice;
 
                   if Choice /= First (Choice_List (Assoc))
                     or else Present (Next (Choice))
@@ -2289,7 +2289,7 @@ package body Sem_Aggr is
 
       if Present (Expressions (N))
         and then (Nb_Choices > 1
-                   or else (Nb_Choices = 1 and then not Others_Present))
+                   or else (Nb_Choices = 1 and then No (Others_N)))
       then
          Error_Msg_N
            ("cannot mix named and positional associations in array aggregate",
@@ -2299,16 +2299,11 @@ package body Sem_Aggr is
 
       --  Test for the validity of an others choice if present
 
-      if Others_Present and then not Others_Allowed then
-         declare
-            Others_N : constant Node_Id :=
-              First (Choice_List (First (Component_Associations (N))));
-         begin
-            Error_Msg_N ("OTHERS choice not allowed here", Others_N);
-            Error_Msg_N ("\qualify the aggregate with a constrained subtype "
-                         & "to provide bounds for it", Others_N);
-            return Failure;
-         end;
+      if Present (Others_N) and then not Others_Allowed then
+         Error_Msg_N ("OTHERS choice not allowed here", Others_N);
+         Error_Msg_N ("\qualify the aggregate with a constrained subtype "
+                      & "to provide bounds for it", Others_N);
+         return Failure;
       end if;
 
       --  Protect against cascaded errors
@@ -2320,7 +2315,7 @@ package body Sem_Aggr is
       --  STEP 2: Process named components
 
       if No (Expressions (N)) then
-         if Others_Present then
+         if Present (Others_N) then
             Case_Table_Size := Nb_Choices - 1;
          else
             Case_Table_Size := Nb_Choices;
@@ -2709,7 +2704,7 @@ package body Sem_Aggr is
 
                      if Lo_Val <= Hi_Val
                        or else (Lo_Val > Hi_Val + 1
-                                 and then not Others_Present)
+                                 and then No (Others_N))
                      then
                         Missing_Or_Duplicates := True;
                         exit;
@@ -2796,7 +2791,7 @@ package body Sem_Aggr is
                      --  Loop through entries in table to find missing indexes.
                      --  Not needed if others, since missing impossible.
 
-                     if not Others_Present then
+                     if No (Others_N) then
                         for J in 2 .. Nb_Discrete_Choices loop
                            Lo_Val := Expr_Value (Table (J).Lo);
                            Hi_Val := Table (J - 1).Highest;
@@ -2862,7 +2857,7 @@ package body Sem_Aggr is
             --  If Others is present, then bounds of aggregate come from the
             --  index constraint (not the choices in the aggregate itself).
 
-            if Others_Present then
+            if Present (Others_N) then
                Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
 
                --  Abandon processing if either bound is already signalled as
@@ -3043,7 +3038,7 @@ package body Sem_Aggr is
             Next (Expr);
          end loop;
 
-         if Others_Present then
+         if Present (Others_N) then
             Assoc := Last (Component_Associations (N));
 
             --  Ada 2005 (AI-231)
@@ -3102,7 +3097,7 @@ package body Sem_Aggr is
 
          --  STEP 3 (B): Compute the aggregate bounds
 
-         if Others_Present then
+         if Present (Others_N) then
             Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
 
          else
@@ -3126,7 +3121,7 @@ package body Sem_Aggr is
 
       --  Check (B)
 
-      if Others_Present and then Nb_Discrete_Choices > 0 then
+      if Present (Others_N) and then Nb_Discrete_Choices > 0 then
          Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High);
          Check_Bounds (Index_Typ_Low, Index_Typ_High,
                        Choices_Low, Choices_High);
@@ -3135,7 +3130,7 @@ package body Sem_Aggr is
 
       --  Check (C)
 
-      elsif Others_Present and then Nb_Elements > 0 then
+      elsif Present (Others_N) and then Nb_Elements > 0 then
          Check_Length (Aggr_Low, Aggr_High, Nb_Elements);
          Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements);
          Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements);
@@ -3154,7 +3149,7 @@ package body Sem_Aggr is
       --  to tree and analyze first. Reset analyzed flag to ensure it will get
       --  analyzed when it is a literal bound whose type must be properly set.
 
-      if Others_Present or else Nb_Discrete_Choices > 0 then
+      if Present (Others_N) or else Nb_Discrete_Choices > 0 then
          Aggr_High := Duplicate_Subexpr (Aggr_High);
 
          if Etype (Aggr_High) = Universal_Integer then
@@ -3186,7 +3181,7 @@ package body Sem_Aggr is
       Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
       Check_Unset_Reference (Aggregate_Bounds (N));
 
-      if not Others_Present and then Nb_Discrete_Choices = 0 then
+      if No (Others_N) and then Nb_Discrete_Choices = 0 then
          Set_High_Bound
            (Aggregate_Bounds (N),
             Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
-- 
2.43.2

[COMMITTED 22/35] ada: Clarify code for aggregate warnings

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

This patch improves comments in code that emits warnings about
particular situations involving aggregates. It also removes a
conjunct in a condition that's useless because always true in the
context of the test.

gcc/ada/

	* sem_aggr.adb (Resolve_Array_Aggregate): Improve comments
	and condition.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_aggr.adb | 52 +++++++++++++++++++++-----------------------
 1 file changed, 25 insertions(+), 27 deletions(-)

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index ee9beb04c9a..14c68b5eaf3 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2873,9 +2873,9 @@ package body Sem_Aggr is
             --  No others clause present
 
             else
-               --  Special processing if others allowed and not present. This
-               --  means that the bounds of the aggregate come from the index
-               --  constraint (and the length must match).
+               --  Special processing if others allowed and not present. In
+               --  this case, the bounds of the aggregate come from the
+               --  choices (RM 4.3.3 (27)).
 
                if Others_Allowed then
                   Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
@@ -2890,30 +2890,28 @@ package body Sem_Aggr is
                      return False;
                   end if;
 
-                  --  If others allowed, and no others present, then the array
-                  --  should cover all index values. If it does not, we will
-                  --  get a length check warning, but there is two cases where
-                  --  an additional warning is useful:
-
-                  --  If we have no positional components, and the length is
-                  --  wrong (which we can tell by others being allowed with
-                  --  missing components), and the index type is an enumeration
-                  --  type, then issue appropriate warnings about these missing
-                  --  components. They are only warnings, since the aggregate
-                  --  is fine, it's just the wrong length. We skip this check
-                  --  for standard character types (since there are no literals
-                  --  and it is too much trouble to concoct them), and also if
-                  --  any of the bounds have values that are not known at
-                  --  compile time.
-
-                  --  Another case warranting a warning is when the length
-                  --  is right, but as above we have an index type that is
-                  --  an enumeration, and the bounds do not match. This is a
-                  --  case where dubious sliding is allowed and we generate a
-                  --  warning that the bounds do not match.
-
-                  if No (Expressions (N))
-                    and then Nkind (Index) = N_Range
+                  --  If there is an applicable index constraint and others is
+                  --  not present, then sliding is allowed and only a length
+                  --  check will be performed. However, additional warnings are
+                  --  useful if the index type is an enumeration type, as
+                  --  sliding is dubious in this case. We emit two kinds of
+                  --  warnings:
+                  --
+                  --    1. If the length is wrong then there are missing
+                  --       components; we issue appropriate warnings about
+                  --       these missing components. They are only warnings,
+                  --       since the aggregate is fine, it's just the wrong
+                  --       length. We skip this check for standard character
+                  --       types (since there are no literals and it is too
+                  --       much trouble to concoct them), and also if any of
+                  --       the bounds have values that are not known at compile
+                  --       time.
+                  --
+                  --    2. If the length is right but the bounds do not match,
+                  --       we issue a warning, as we consider sliding dubious
+                  --       when the index type is an enumeration type.
+
+                  if Nkind (Index) = N_Range
                     and then Is_Enumeration_Type (Etype (Index))
                     and then not Is_Standard_Character_Type (Etype (Index))
                     and then Compile_Time_Known_Value (Aggr_Low)
-- 
2.43.2

[COMMITTED 23/35] ada: Disable Equivalent_Array_Aggregate optimization if predicates involved

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

In most paths, the function Build_Equivalent_Record_Aggregate was already
testing Has_Predicates for a given component type and conditionally returning
an Empty result. This is also needed in the case of a scalar component type.
Without it, we can build corrupt trees that fail use-before-definition
detection checks in gigi.

gcc/ada/

	* exp_ch3.adb (Build_Equivalent_Record_Aggregate): Add
	Has_Predicates test for a scalar component to match what is
	already done for other kinds of components.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_ch3.adb | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 5764b22b800..f6314dff285 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1950,6 +1950,7 @@ package body Exp_Ch3 is
               or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
               or else not
                 Compile_Time_Known_Value (Type_High_Bound (Comp_Type))
+              or else Has_Predicates (Etype (Comp))
             then
                Initialization_Warning (T);
                return Empty;
-- 
2.43.2

[COMMITTED 24/35] ada: Do not query the modification time of a special file.

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

In Ada.Directories, the function Modification_Time raises Name_Error if it is
called for a special file. So don't do that in Start_Search_Internal.

gcc/ada/

	* libgnat/a-direct.adb (Start_Search_Internal): Do not call
	Modification_Time for a special file; declare a Calendar.Time
	constant No_Time and use that instead.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/libgnat/a-direct.adb | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb
index 32e020c48c3..adff12277e8 100644
--- a/gcc/ada/libgnat/a-direct.adb
+++ b/gcc/ada/libgnat/a-direct.adb
@@ -29,7 +29,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Ada.Calendar;               use Ada.Calendar;
+with Ada.Calendar.Formatting;    use Ada.Calendar;
 with Ada.Characters.Handling;    use Ada.Characters.Handling;
 with Ada.Containers.Vectors;
 with Ada.Directories.Validity;   use Ada.Directories.Validity;
@@ -1392,6 +1392,17 @@ package body Ada.Directories is
                   end record;
 
                   Res : Result := (Found => False);
+
+                  --  This declaration of No_Time copied from GNAT.Calendar
+                  --  because adding a "with GNAT.Calendar;" to this unit
+                  --  results in problems.
+
+                  No_Time : constant Ada.Calendar.Time :=
+                    Ada.Calendar.Formatting.Time_Of
+                      (Ada.Calendar.Year_Number'First,
+                       Ada.Calendar.Month_Number'First,
+                       Ada.Calendar.Day_Number'First,
+                       Time_Zone => 0);
                begin
                   --  Get the file attributes for the directory item
 
@@ -1452,7 +1463,10 @@ package body Ada.Directories is
                               Full_Name         => To_Unbounded_String (Path),
                               Attr_Error_Code   => 0,
                               Kind              => Res.Kind,
-                              Modification_Time => Modification_Time (Path),
+                              Modification_Time =>
+                               (if Res.Kind = Special_File
+                                  then No_Time
+                                  else Modification_Time (Path)),
                               Size              => Res.Size));
                      end if;
                   end if;
-- 
2.43.2

[COMMITTED 25/35] ada: Fix for validity checking and conditional evaluation of 'Old

[Marc Poulhiès]

From: Piotr Trojanek <trojanek@adacore.com>

Detection of expression that are "known on entry" (as defined in Ada
2022 RM 6.1.1(20/5)) was confused by validity checks when used from
within expansion of attribute 'Old.

gcc/ada/

	* sem_util.adb (Is_Known_On_Entry): Handle constants introduced
	by validity checks.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_util.adb | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index be777d26e46..d512d462b44 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -30791,6 +30791,14 @@ package body Sem_Util is
                               return False;
                            end if;
 
+                           --  Handle constants introduced by side-effect
+                           --  removal, e.g. by validity checks.
+
+                           if not Comes_From_Source (Obj) then
+                              return
+                                Is_Known_On_Entry (Expression (Parent (Obj)));
+                           end if;
+
                            --  return False if not "all views are constant".
                            if Is_Immutably_Limited_Type (Obj_Typ)
                              or Needs_Finalization (Obj_Typ)
-- 
2.43.2

[COMMITTED 26/35] ada: Factor out duplicated code in bodies of System.Task_Primitives.Operations

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The duplication is present in some POSIX-like implementations (POSIX
and RTEMS) while it has already been eliminated in others (Linux, QNX).  The
latter implementations are also slightly modified for consistency's sake.

No functional changes.

gcc/ada/

	* libgnarl/s-taprop__dummy.adb (Initialize_Lock): Fix formatting.
	* libgnarl/s-taprop__linux.adb (RTS_Lock_Ptr): Delete.
	(Init_Mutex): Rename into...
	(Initialize_Lock): ...this.
	(Initialize_Lock [Lock]): Call above procedure.
	(Initialize_Lock [RTS_Lock]): Likewise.
	(Initialize_TCB): Likewise.
	* libgnarl/s-taprop__posix.adb (Initialize_Lock): New procedure
	factored out from the other two homonyms.
	(Initialize_Lock [Lock]): Call above procedure.
	(Initialize_Lock [RTS_Lock]): Likewise.
	* libgnarl/s-taprop__qnx.adb (RTS_Lock_Ptr): Delete.
	(Init_Mutex): Rename into...
	(Initialize_Lock): ...this.
	(Initialize_Lock [Lock]): Call above procedure.
	(Initialize_Lock [RTS_Lock]): Likewise.
	(Initialize_TCB): Likewise.
	* libgnarl/s-taprop__rtems.adb (Initialize_Lock): New procedure
	factored out from the other two homonyms.
	(Initialize_Lock [Lock]): Call above procedure.
	(Initialize_Lock [RTS_Lock]): Likewise.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/libgnarl/s-taprop__dummy.adb |  4 +-
 gcc/ada/libgnarl/s-taprop__linux.adb | 47 ++++++++++-----------
 gcc/ada/libgnarl/s-taprop__posix.adb | 61 +++++++++-------------------
 gcc/ada/libgnarl/s-taprop__qnx.adb   | 46 ++++++++++-----------
 gcc/ada/libgnarl/s-taprop__rtems.adb | 61 +++++++++-------------------
 5 files changed, 90 insertions(+), 129 deletions(-)

diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb
index 90c4cd4cf72..829d595694c 100644
--- a/gcc/ada/libgnarl/s-taprop__dummy.adb
+++ b/gcc/ada/libgnarl/s-taprop__dummy.adb
@@ -239,7 +239,9 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level) is
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
+   is
    begin
       null;
    end Initialize_Lock;
diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index d6a29b5e158..74717cb2d2b 100644
--- a/gcc/ada/libgnarl/s-taprop__linux.adb
+++ b/gcc/ada/libgnarl/s-taprop__linux.adb
@@ -248,10 +248,10 @@ package body System.Task_Primitives.Operations is
    --  as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
    --  permission, then a request for Ceiling_Locking is ignored.
 
-   type RTS_Lock_Ptr is not null access all RTS_Lock;
-
-   function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
-   --  Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
+   function Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : Any_Priority) return C.int;
+   --  Initialize the lock L. If Ceiling_Support is True, then set the ceiling
    --  to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
 
    -------------------
@@ -340,11 +340,20 @@ package body System.Task_Primitives.Operations is
 
    function Self return Task_Id renames Specific.Self;
 
-   ----------------
-   -- Init_Mutex --
-   ----------------
+   ---------------------
+   -- Initialize_Lock --
+   ---------------------
 
-   function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
+   --  Note: mutexes and cond_variables needed per-task basis are initialized
+   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+   --  status change of RTS. Therefore raising Storage_Error in the following
+   --  routines should be able to be handled safely.
+
+   function Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : Any_Priority) return C.int
+   is
       Mutex_Attr : aliased pthread_mutexattr_t;
       Result, Result_2 : C.int;
 
@@ -377,17 +386,7 @@ package body System.Task_Primitives.Operations is
       Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
       pragma Assert (Result_2 = 0);
       return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
-   end Init_Mutex;
-
-   ---------------------
-   -- Initialize_Lock --
-   ---------------------
-
-   --  Note: mutexes and cond_variables needed per-task basis are initialized
-   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
-   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
-   --  status change of RTS. Therefore raising Storage_Error in the following
-   --  routines should be able to be handled safely.
+   end Initialize_Lock;
 
    procedure Initialize_Lock
      (Prio : Any_Priority;
@@ -420,18 +419,19 @@ package body System.Task_Primitives.Operations is
          end;
 
       else
-         if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
+         if Initialize_Lock (L.WO'Access, Prio) = ENOMEM then
             raise Storage_Error with "Failed to allocate a lock";
          end if;
       end if;
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
    is
       pragma Unreferenced (Level);
    begin
-      if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
+      if Initialize_Lock (L, Any_Priority'Last) = ENOMEM then
          raise Storage_Error with "Failed to allocate a lock";
       end if;
    end Initialize_Lock;
@@ -840,7 +840,8 @@ package body System.Task_Primitives.Operations is
 
       Self_ID.Common.LL.Thread := Null_Thread_Id;
 
-      if Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0 then
+      if Initialize_Lock (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
+      then
          Succeeded := False;
          return;
       end if;
diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb
index 79694129227..a71e42112ac 100644
--- a/gcc/ada/libgnarl/s-taprop__posix.adb
+++ b/gcc/ada/libgnarl/s-taprop__posix.adb
@@ -211,6 +211,11 @@ package body System.Task_Primitives.Operations is
    pragma Import (C,
      GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
 
+   procedure Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : System.Any_Priority);
+   --  Initialize an RTS_Lock with the specified priority
+
    -------------------
    -- Abort_Handler --
    -------------------
@@ -319,11 +324,11 @@ package body System.Task_Primitives.Operations is
    --  routines should be able to be handled safely.
 
    procedure Initialize_Lock
-     (Prio : System.Any_Priority;
-      L    : not null access Lock)
+     (L    : not null access RTS_Lock;
+      Prio : System.Any_Priority)
    is
       Attributes : aliased pthread_mutexattr_t;
-      Result : Interfaces.C.int;
+      Result     : Interfaces.C.int;
 
    begin
       Result := pthread_mutexattr_init (Attributes'Access);
@@ -348,7 +353,7 @@ package body System.Task_Primitives.Operations is
          pragma Assert (Result = 0);
       end if;
 
-      Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
+      Result := pthread_mutex_init (L, Attributes'Access);
       pragma Assert (Result = 0 or else Result = ENOMEM);
 
       if Result = ENOMEM then
@@ -361,46 +366,20 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (Prio : System.Any_Priority;
+      L    : not null access Lock)
    is
-      pragma Unreferenced (Level);
-
-      Attributes : aliased pthread_mutexattr_t;
-      Result     : Interfaces.C.int;
-
    begin
-      Result := pthread_mutexattr_init (Attributes'Access);
-      pragma Assert (Result = 0 or else Result = ENOMEM);
-
-      if Result = ENOMEM then
-         raise Storage_Error;
-      end if;
-
-      if Locking_Policy = 'C' then
-         Result := pthread_mutexattr_setprotocol
-           (Attributes'Access, PTHREAD_PRIO_PROTECT);
-         pragma Assert (Result = 0);
-
-         Result := pthread_mutexattr_setprioceiling
-            (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
-         pragma Assert (Result = 0);
-
-      elsif Locking_Policy = 'I' then
-         Result := pthread_mutexattr_setprotocol
-           (Attributes'Access, PTHREAD_PRIO_INHERIT);
-         pragma Assert (Result = 0);
-      end if;
-
-      Result := pthread_mutex_init (L, Attributes'Access);
-      pragma Assert (Result = 0 or else Result = ENOMEM);
-
-      if Result = ENOMEM then
-         Result := pthread_mutexattr_destroy (Attributes'Access);
-         raise Storage_Error;
-      end if;
+      Initialize_Lock (L.WO'Access, Prio);
+   end Initialize_Lock;
 
-      Result := pthread_mutexattr_destroy (Attributes'Access);
-      pragma Assert (Result = 0);
+   procedure Initialize_Lock
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
+   is
+      pragma Unreferenced (Level);
+   begin
+      Initialize_Lock (L, System.Any_Priority'Last);
    end Initialize_Lock;
 
    -------------------
diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index 8b98af7284e..2f11d2821fb 100644
--- a/gcc/ada/libgnarl/s-taprop__qnx.adb
+++ b/gcc/ada/libgnarl/s-taprop__qnx.adb
@@ -115,10 +115,10 @@ package body System.Task_Primitives.Operations is
    Abort_Handler_Installed : Boolean := False;
    --  True if a handler for the abort signal is installed
 
-   type RTS_Lock_Ptr is not null access all RTS_Lock;
-
-   function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return int;
-   --  Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
+   function Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : Any_Priority) return int;
+   --  Initialize the lock L. If Ceiling_Support is True, then set the ceiling
    --  to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
 
    function Get_Policy (Prio : System.Any_Priority) return Character;
@@ -319,11 +319,19 @@ package body System.Task_Primitives.Operations is
 
    function Self return Task_Id renames Specific.Self;
 
-   ----------------
-   -- Init_Mutex --
-   ----------------
+   ---------------------
+   -- Initialize_Lock --
+   ---------------------
+
+   --  Note: mutexes and cond_variables needed per-task basis are initialized
+   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+   --  status change of RTS. Therefore raising Storage_Error in the following
+   --  routines should be able to be handled safely.
 
-   function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return int
+   function Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : Any_Priority) return int
    is
       Attributes : aliased pthread_mutexattr_t;
       Result     : int;
@@ -365,35 +373,26 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result_2 = 0);
 
       return Result;
-   end Init_Mutex;
-
-   ---------------------
-   -- Initialize_Lock --
-   ---------------------
-
-   --  Note: mutexes and cond_variables needed per-task basis are initialized
-   --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
-   --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
-   --  status change of RTS. Therefore raising Storage_Error in the following
-   --  routines should be able to be handled safely.
+   end Initialize_Lock;
 
    procedure Initialize_Lock
      (Prio : System.Any_Priority;
       L    : not null access Lock)
    is
    begin
-      if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
+      if Initialize_Lock (L.WO'Access, Prio) = ENOMEM then
          raise Storage_Error with "Failed to allocate a lock";
       end if;
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
    is
       pragma Unreferenced (Level);
 
    begin
-      if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
+      if Initialize_Lock (L, Any_Priority'Last) = ENOMEM then
          raise Storage_Error with "Failed to allocate a lock";
       end if;
    end Initialize_Lock;
@@ -706,7 +705,8 @@ package body System.Task_Primitives.Operations is
       Next_Serial_Number := Next_Serial_Number + 1;
       pragma Assert (Next_Serial_Number /= 0);
 
-      Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last);
+      Result :=
+        Initialize_Lock (Self_ID.Common.LL.L'Access, Any_Priority'Last);
       pragma Assert (Result = 0);
 
       if Result /= 0 then
diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb
index 68a956e5c06..b041592cbe0 100644
--- a/gcc/ada/libgnarl/s-taprop__rtems.adb
+++ b/gcc/ada/libgnarl/s-taprop__rtems.adb
@@ -202,6 +202,11 @@ package body System.Task_Primitives.Operations is
    pragma Import (C,
      GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
 
+   procedure Initialize_Lock
+     (L    : not null access RTS_Lock;
+      Prio : System.Any_Priority);
+   --  Initialize an RTS_Lock with the specified priority
+
    -------------------
    -- Abort_Handler --
    -------------------
@@ -329,11 +334,11 @@ package body System.Task_Primitives.Operations is
    --  routines should be able to be handled safely.
 
    procedure Initialize_Lock
-     (Prio : System.Any_Priority;
-      L    : not null access Lock)
+     (L    : not null access RTS_Lock;
+      Prio : System.Any_Priority)
    is
       Attributes : aliased pthread_mutexattr_t;
-      Result : Interfaces.C.int;
+      Result     : Interfaces.C.int;
 
    begin
       Result := pthread_mutexattr_init (Attributes'Access);
@@ -358,7 +363,7 @@ package body System.Task_Primitives.Operations is
          pragma Assert (Result = 0);
       end if;
 
-      Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
+      Result := pthread_mutex_init (L, Attributes'Access);
       pragma Assert (Result = 0 or else Result = ENOMEM);
 
       if Result = ENOMEM then
@@ -371,46 +376,20 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (Prio : System.Any_Priority;
+      L    : not null access Lock)
    is
-      pragma Unreferenced (Level);
-
-      Attributes : aliased pthread_mutexattr_t;
-      Result     : Interfaces.C.int;
-
    begin
-      Result := pthread_mutexattr_init (Attributes'Access);
-      pragma Assert (Result = 0 or else Result = ENOMEM);
-
-      if Result = ENOMEM then
-         raise Storage_Error;
-      end if;
-
-      if Locking_Policy = 'C' then
-         Result := pthread_mutexattr_setprotocol
-           (Attributes'Access, PTHREAD_PRIO_PROTECT);
-         pragma Assert (Result = 0);
-
-         Result := pthread_mutexattr_setprioceiling
-            (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
-         pragma Assert (Result = 0);
-
-      elsif Locking_Policy = 'I' then
-         Result := pthread_mutexattr_setprotocol
-           (Attributes'Access, PTHREAD_PRIO_INHERIT);
-         pragma Assert (Result = 0);
-      end if;
-
-      Result := pthread_mutex_init (L, Attributes'Access);
-      pragma Assert (Result = 0 or else Result = ENOMEM);
-
-      if Result = ENOMEM then
-         Result := pthread_mutexattr_destroy (Attributes'Access);
-         raise Storage_Error;
-      end if;
+      Initialize_Lock (L.WO'Access, Prio);
+   end Initialize_Lock;
 
-      Result := pthread_mutexattr_destroy (Attributes'Access);
-      pragma Assert (Result = 0);
+   procedure Initialize_Lock
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
+   is
+      pragma Unreferenced (Level);
+   begin
+      Initialize_Lock (L, System.Any_Priority'Last);
    end Initialize_Lock;
 
    -------------------
-- 
2.43.2

[COMMITTED 27/35] ada: Bug in computing local restrictions inherited from enclosing scopes.

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

In the function Local_Restrict.Active_Restriction, we traverse enclosing
scopes looking for a relevant Local_Restrictions aspect specification.
Fix a bug in this traversal.

gcc/ada/

	* local_restrict.adb (Active_Restriction): When traversing scopes,
	do not skip over a subprogram body.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/local_restrict.adb | 32 +++++++++++++++++++-------------
 1 file changed, 19 insertions(+), 13 deletions(-)

diff --git a/gcc/ada/local_restrict.adb b/gcc/ada/local_restrict.adb
index 6e91c8a2e2a..3be94049928 100644
--- a/gcc/ada/local_restrict.adb
+++ b/gcc/ada/local_restrict.adb
@@ -90,22 +90,28 @@ package body Local_Restrict is
             return Result;
          end if;
 
-         Scop := Enclosing_Declaration (Scop);
-         if Present (Scop) then
-            Scop := Parent (Scop);
+         declare
+            Saved_Scope : constant Node_Id := Scop;
+         begin
+            Scop := Enclosing_Declaration (Scop);
             if Present (Scop) then
-               --  For a subprogram associated with a type, we don't care
-               --  where the type was frozen; continue from the type.
-
-               if Nkind (Scop) = N_Freeze_Entity then
-                  Scop := Scope (Entity (Scop));
-               elsif Nkind (Parent (Scop)) = N_Freeze_Entity then
-                  Scop := Scope (Entity (Parent (Scop)));
-               else
-                  Scop := Find_Enclosing_Scope (Scop);
+               Scop := Parent (Scop);
+               if Present (Scop) then
+                  --  For a subprogram associated with a type, we don't care
+                  --  where the type was frozen; continue from the type.
+
+                  if Nkind (Scop) = N_Freeze_Entity then
+                     Scop := Scope (Entity (Scop));
+                  elsif Nkind (Parent (Scop)) = N_Freeze_Entity then
+                     Scop := Scope (Entity (Parent (Scop)));
+                  elsif Present (Scope (Saved_Scope)) then
+                     Scop := Scope (Saved_Scope);
+                  else
+                     Scop := Find_Enclosing_Scope (Scop);
+                  end if;
                end if;
             end if;
-         end if;
+         end;
       end loop;
 
       return Empty;
-- 
2.43.2

[COMMITTED 28/35] ada: Document secondary usage of Materialize_Entity flag

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The flag is also used by the semantic analyzer.

gcc/ada/

	* einfo.ads (Materialize_Entity): Document secondary usage.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/einfo.ads | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 71c560d5272..e5110f51670 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3584,10 +3584,11 @@ package Einfo is
 --       tasks implementing such interface.
 
 --    Materialize_Entity
---       Defined in all entities. Set only for renamed obects which should be
+--       Defined in all entities. Set mostly for renamed objects that should be
 --       materialized for debugging purposes. This means that a memory location
 --       containing the renamed address should be allocated. This is needed so
---       that the debugger can find the entity.
+--       that the debugger can find the entity. Also set on types built in the
+--       case of unanalyzed packages referenced through a limited_with clause.
 
 --    May_Inherit_Delayed_Rep_Aspects
 --       Defined in all entities for types and subtypes. Set if the type is
-- 
2.43.2

[COMMITTED 29/35] ada: Replace spinlocks with fully-fledged locks in finalization collections

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

This replaces spinlocks with fully-fledged locks in finalization collections
because the former are deemed problematic with tasks that can be preempted.

Because of the requirement to avoid dragging the tasking runtime when it is
not necessary, the implementation goes through the usual soft links, with an
additional hurdle that space must be reserved for the lock in any case since
it is part of the ABI.  This entails the introduction of the System.OS_Locks
unit in the non-tasking runtime and the modification of the tasking runtime
to also use this unit.

This in turn requires a small adjustment: because of the presence of pre-
and post-conditions in Interfaces.C and of the limitations of the RTSfind
mechanism, the System.Finalization_Primitives unit must be preloaded, as
what is done for the Ada.Strings.Text_Buffers unit.

This effectively reverts the implementation to using the global task lock on
bare board platforms.

gcc/ada/

	* Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-oslock$(objext).
	(LIBGNAT_TARGET_PAIRS): Use s-oslock__dummy.ads by default.
	Set specific s-oslock.ads source file for all the platforms.
	* exp_ch7.ads (Preload_Finalization_Collection): New procedure.
	* exp_ch7.adb (Allows_Finalization_Collection): Return False if
	System.Finalization_Primitives has not been preloaded.
	(Preload_Finalization_Collection): New procedure.
	* opt.ads (Interface_Seen): New boolean variable.
	* s-oscons-tmplt.c: Use "N" string for pragma Style_Checks.
	* scng.adb (Scan): Set Interface_Seen upon seeing "interface".
	* sem_ch10.adb: Add clause for Exp_Ch7.
	(Analyze_Compilation_Unit): Call Preload_Finalization_Collection
	after the context of the unit is analyzed.
	* libgnarl/a-rttiev.adb: Add with clause for System.OS_Locks and
	alphabetize others.
	(Event_Queue_Lock): Adjust qualified name of subtype.
	* libgnarl/s-osinte__aix.ads: Add with clause for System.OS_Locks
	and change pthread_mutex_t into a local subtype.
	* libgnarl/s-osinte__android.ads: Likewise.
	* libgnarl/s-osinte__darwin.ads: Likewise.
	* libgnarl/s-osinte__dragonfly.ads: Likewise.
	* libgnarl/s-osinte__freebsd.ads: Likewise.
	* libgnarl/s-osinte__gnu.ads: Likewise.
	* libgnarl/s-osinte__hpux-dce.ads: Likewise.
	* libgnarl/s-osinte__hpux.ads: Add Likewise.
	* libgnarl/s-osinte__kfreebsd-gnu.ads: Likewise.
	* libgnarl/s-osinte__linux.ads: Likewise.
	* libgnarl/s-osinte__lynxos178e.ads: Likewise.
	* libgnarl/s-osinte__qnx.ads: Likewise.
	* libgnarl/s-osinte__rtems.ads: Likewise.
	* libgnarl/s-osinte__mingw.ads: Add with clause for System.OS_Locks
	and change CRITICAL_SECTION into a local subtype.  Add declarations
	for imported procedures dealing with CRITICAL_SECTION.
	* libgnarl/s-osinte__solaris.ads: Add with clause for System.OS_Locks
	and change mutex_t into a local subtype.
	* libgnarl/s-osinte__vxworks.ads: Add missing blank line.
	* libgnarl/s-taprop.ads: Alphabetize clauses and package renamings.
	Use qualified name for RTS_Lock throughout.
	* libgnarl/s-taprop__dummy.adb: Add use clause for System.OS_Locks
	and alphabetize others.
	* libgnarl/s-taprop__hpux-dce.adb: Likewise.
	* libgnarl/s-taprop__linux.adb: Likewise.
	* libgnarl/s-taprop__posix.adb: Likewise.
	* libgnarl/s-taprop__qnx.adb: Likewise.
	* libgnarl/s-taprop__rtems.adb: Likewise.
	* libgnarl/s-taprop__solaris.adb: Likewise.
	* libgnarl/s-taprop__vxworks.adb: Likewise.
	* libgnarl/s-taprop__mingw.adb: Likewise.  Remove declarations for
	imported procedures dealing with CRITICAL_SECTION.
	* libgnarl/s-tarest.adb: Add with clause for System.OS_Locks and
	alphabetize others.
	(Global_Task_Lock): Adjust qualified name of subtype.
	* libgnarl/s-tasini.adb: Add clause for System.OS_Locks.
	(Initialize_RTS_Lock): New procedure.
	(Finalize_RTS_Lock): Likewise.
	(Acquire_RTS_Lock): Likewise.
	(Release_RTS_Lock): Likewise.
	(Init_RTS): Add compile-time assertions for RTS_Lock types.
	Set the soft links for the RTS lock manipulation routines.
	* libgnarl/s-taspri__dummy.ads: Add with clause for System.OS_Locks.
	(RTS_Lock): Delete and adjust throughout accordingly.
	* libgnarl/s-taspri__hpux-dce.ads: Likewise.
	* libgnarl/s-taspri__lynxos.ads: Likewise.
	* libgnarl/s-taspri__mingw.ads: Likewise.
	* libgnarl/s-taspri__posix-noaltstack.ads: Likewise.
	* libgnarl/s-taspri__posix.ads: Likewise.
	* libgnarl/s-taspri__solaris.ads: Likewise.
	* libgnarl/s-taspri__vxworks.ads: Likewise.
	* libgnat/s-finpri.ads: Add clause for System.OS_Locks.
	(Finalization_Collection): Change type of Lock.
	* libgnat/s-finpri.adb (Initialize): Call Initialize_RTS_Lock.
	(Lock_Collection): Call Acquire_RTS_Lock.
	(Unlock_Collection): Call Release_RTS_Lock.
	* libgnat/s-oslock__dummy.ads: New file.
	* libgnat/s-oslock__hpux-dce.ads: Likewise.
	* libgnat/s-oslock__mingw.ads: Likewise.
	* libgnat/s-oslock__posix.ads: Likewise.
	* libgnat/s-oslock__solaris.ads: Likewise.
	* libgnat/s-oslock__vxworks.ads: Likewise.
	* libgnat/s-soflin.ads (Null_Set_Address): New null procedure.
	(Initialize_RTS_Lock): New soft link.
	(Finalize_RTS_Lock): Likewise.
	(Acquire_RTS_Lock): Likewise.
	(Release_RTS_Lock): Likewise.
	* exp_ch4.adb (Expand_N_Allocator): In the subtype indication case,
	call Apply_Predicate_Check on the resulting access value if need be.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/Makefile.rtl                          | 41 +++++++++
 gcc/ada/exp_ch4.adb                           |  2 +
 gcc/ada/exp_ch7.adb                           | 38 +++++++++
 gcc/ada/exp_ch7.ads                           |  6 ++
 gcc/ada/libgnarl/a-rttiev.adb                 |  7 +-
 gcc/ada/libgnarl/s-osinte__aix.ads            | 18 +---
 gcc/ada/libgnarl/s-osinte__android.ads        | 11 +--
 gcc/ada/libgnarl/s-osinte__darwin.ads         | 10 +--
 gcc/ada/libgnarl/s-osinte__dragonfly.ads      |  4 +-
 gcc/ada/libgnarl/s-osinte__freebsd.ads        |  4 +-
 gcc/ada/libgnarl/s-osinte__gnu.ads            | 50 +++--------
 gcc/ada/libgnarl/s-osinte__hpux-dce.ads       |  6 +-
 gcc/ada/libgnarl/s-osinte__hpux.ads           | 23 +----
 gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads   | 14 +---
 gcc/ada/libgnarl/s-osinte__linux.ads          | 11 +--
 gcc/ada/libgnarl/s-osinte__lynxos178e.ads     | 15 +---
 gcc/ada/libgnarl/s-osinte__mingw.ads          | 34 ++++----
 gcc/ada/libgnarl/s-osinte__qnx.ads            | 13 ++-
 gcc/ada/libgnarl/s-osinte__rtems.ads          | 10 +--
 gcc/ada/libgnarl/s-osinte__solaris.ads        | 14 +---
 gcc/ada/libgnarl/s-osinte__vxworks.ads        |  1 +
 gcc/ada/libgnarl/s-taprop.ads                 | 12 +--
 gcc/ada/libgnarl/s-taprop__dummy.adb          |  3 +-
 gcc/ada/libgnarl/s-taprop__hpux-dce.adb       | 10 ++-
 gcc/ada/libgnarl/s-taprop__linux.adb          | 19 +++--
 gcc/ada/libgnarl/s-taprop__mingw.adb          | 29 +------
 gcc/ada/libgnarl/s-taprop__posix.adb          | 10 ++-
 gcc/ada/libgnarl/s-taprop__qnx.adb            | 12 +--
 gcc/ada/libgnarl/s-taprop__rtems.adb          | 10 ++-
 gcc/ada/libgnarl/s-taprop__solaris.adb        | 12 +--
 gcc/ada/libgnarl/s-taprop__vxworks.adb        | 12 +--
 gcc/ada/libgnarl/s-tarest.adb                 |  5 +-
 gcc/ada/libgnarl/s-tasini.adb                 | 75 ++++++++++++++++-
 gcc/ada/libgnarl/s-taspri__dummy.ads          |  6 +-
 gcc/ada/libgnarl/s-taspri__hpux-dce.ads       | 15 ++--
 gcc/ada/libgnarl/s-taspri__lynxos.ads         | 16 ++--
 gcc/ada/libgnarl/s-taspri__mingw.ads          | 15 +---
 .../libgnarl/s-taspri__posix-noaltstack.ads   | 22 ++---
 gcc/ada/libgnarl/s-taspri__posix.ads          | 16 ++--
 gcc/ada/libgnarl/s-taspri__solaris.ads        | 39 ++-------
 gcc/ada/libgnarl/s-taspri__vxworks.ads        | 21 +----
 gcc/ada/libgnat/s-finpri.adb                  | 13 +--
 gcc/ada/libgnat/s-finpri.ads                  |  6 +-
 gcc/ada/libgnat/s-oslock__dummy.ads           | 39 +++++++++
 gcc/ada/libgnat/s-oslock__hpux-dce.ads        | 61 ++++++++++++++
 gcc/ada/libgnat/s-oslock__mingw.ads           | 62 ++++++++++++++
 gcc/ada/libgnat/s-oslock__posix.ads           | 57 +++++++++++++
 gcc/ada/libgnat/s-oslock__solaris.ads         | 84 +++++++++++++++++++
 gcc/ada/libgnat/s-oslock__vxworks.ads         | 48 +++++++++++
 gcc/ada/libgnat/s-soflin.ads                  | 14 ++++
 gcc/ada/opt.ads                               |  4 +
 gcc/ada/s-oscons-tmplt.c                      |  4 +-
 gcc/ada/scng.adb                              |  5 +-
 gcc/ada/sem_ch10.adb                          |  3 +
 54 files changed, 723 insertions(+), 368 deletions(-)
 create mode 100644 gcc/ada/libgnat/s-oslock__dummy.ads
 create mode 100644 gcc/ada/libgnat/s-oslock__hpux-dce.ads
 create mode 100644 gcc/ada/libgnat/s-oslock__mingw.ads
 create mode 100644 gcc/ada/libgnat/s-oslock__posix.ads
 create mode 100644 gcc/ada/libgnat/s-oslock__solaris.ads
 create mode 100644 gcc/ada/libgnat/s-oslock__vxworks.ads

diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 9c5bce91cbc..570d0b2703d 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -652,6 +652,7 @@ GNATRTL_NONTASKING_OBJS= \
   s-multip$(objext) \
   s-os_lib$(objext) \
   s-oscons$(objext) \
+  s-oslock$(objext) \
   s-osprim$(objext) \
   s-pack03$(objext) \
   s-pack05$(objext) \
@@ -831,6 +832,7 @@ a-intnam.ads<libgnarl/a-intnam__dummy.ads \
 s-inmaop.adb<libgnarl/s-inmaop__dummy.adb \
 s-intman.adb<libgnarl/s-intman__dummy.adb \
 s-osinte.ads<libgnarl/s-osinte__dummy.ads \
+s-oslock.ads<libgnat/s-oslock__dummy.ads \
 s-osprim.adb<libgnat/s-osprim__posix.adb \
 s-taprop.adb<libgnarl/s-taprop__dummy.adb \
 s-taspri.ads<libgnarl/s-taspri__dummy.ads
@@ -1097,6 +1099,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7%, $(target_cpu) $(targe
   s-intman.adb<libgnarl/s-intman__vxworks.adb \
   s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
   s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
+  s-oslock.ads<libgnat/s-oslock__vxworks.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-parame.ads<libgnat/s-parame__vxworks.ads \
   s-parame.adb<libgnat/s-parame__vxworks.adb \
@@ -1198,6 +1201,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks7%, $(target_cpu) $(target_vend
   s-inmaop.adb<libgnarl/s-inmaop__hwint.adb \
   s-intman.ads<libgnarl/s-intman__vxworks.ads \
   s-intman.adb<libgnarl/s-intman__vxworks.adb \
+  s-oslock.ads<libgnat/s-oslock__vxworks.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-parame.ads<libgnat/s-parame__vxworks.ads \
   s-parame.adb<libgnat/s-parame__vxworks.adb \
@@ -1306,6 +1310,7 @@ ifeq ($(strip $(filter-out aarch64 arm wrs vxworks7%, $(target_cpu) $(target_ven
   s-intman.adb<libgnarl/s-intman__vxworks.adb \
   s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
   s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
+  s-oslock.ads<libgnat/s-oslock__vxworks.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-parame.ads<libgnat/s-parame__vxworks.ads \
   s-parame.adb<libgnat/s-parame__vxworks.adb \
@@ -1386,6 +1391,7 @@ ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__android.ads \
   s-osinte.adb<libgnarl/s-osinte__android.adb \
   s-osinte.ads<libgnarl/s-osinte__android.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1414,6 +1420,7 @@ ifeq ($(strip $(filter-out arm aarch64 %qnx,$(target_cpu) $(target_os))),)
   s-intman.adb<libgnarl/s-intman__qnx.adb \
   s-osinte.adb<libgnarl/s-osinte__qnx.adb \
   s-osinte.ads<libgnarl/s-osinte__qnx.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-qnx.ads<libgnarl/s-qnx.ads \
   s-taprop.adb<libgnarl/s-taprop__qnx.adb \
@@ -1461,6 +1468,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__solaris.adb \
   s-osinte.ads<libgnarl/s-osinte__solaris.ads \
+  s-oslock.ads<libgnat/s-oslock__solaris.ads \
   s-osprim.adb<libgnat/s-osprim__solaris.adb \
   s-taprop.adb<libgnarl/s-taprop__solaris.adb \
   s-tasinf.adb<libgnarl/s-tasinf__solaris.adb \
@@ -1504,6 +1512,7 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__solaris.adb \
   s-osinte.ads<libgnarl/s-osinte__solaris.ads \
+  s-oslock.ads<libgnat/s-oslock__solaris.ads \
   s-osprim.adb<libgnat/s-osprim__solaris.adb \
   s-taprop.adb<libgnarl/s-taprop__solaris.adb \
   s-tasinf.adb<libgnarl/s-tasinf__solaris.adb \
@@ -1577,6 +1586,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
   LIBGNAT_TARGET_PAIRS += \
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -1607,6 +1617,7 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(target_cpu) $(target_os))),)
   s-intman.adb<libgnarl/s-intman__posix.adb \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__kfreebsd-gnu.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1637,6 +1648,7 @@ ifeq ($(strip $(filter-out %86 pc gnu,$(target_cpu) $(target_vendor) $(target_os
   s-intman.adb<libgnarl/s-intman__posix.adb \
   s-osinte.adb<libgnarl/s-osinte__gnu.adb \
   s-osinte.ads<libgnarl/s-osinte__gnu.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1656,6 +1668,7 @@ ifeq ($(strip $(filter-out %86 pc gnu,$(target_cpu) $(target_vendor) $(target_os
   LIBRARY_VERSION := $(LIB_VERSION)
 endif
 
+# x86-64 kfreebsd
 ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
   LIBGNAT_TARGET_PAIRS = \
   a-intnam.ads<libgnarl/a-intnam__freebsd.ads \
@@ -1663,6 +1676,7 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
   s-intman.adb<libgnarl/s-intman__posix.adb \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__kfreebsd-gnu.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1694,6 +1708,7 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
   s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1723,6 +1738,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
   s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1753,6 +1769,7 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
   s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1785,6 +1802,7 @@ ifeq ($(strip $(filter-out %86_64 dragonfly%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.adb<libgnarl/s-osinte__dragonfly.adb \
   s-osinte.ads<libgnarl/s-osinte__dragonfly.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1816,6 +1834,7 @@ ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -1856,6 +1875,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(tar
   s-osinte.adb<libgnarl/s-osinte__hpux-dce.adb \
   s-osinte.ads<libgnarl/s-osinte__hpux-dce.ads \
   s-parame.ads<libgnat/s-parame__hpux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__hpux-dce.adb \
   s-taspri.ads<libgnarl/s-taspri__hpux-dce.ads \
@@ -1875,6 +1895,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor) $(tar
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__hpux.ads \
   s-parame.ads<libgnat/s-parame__hpux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-traceb.adb<libgnat/s-traceb__hpux.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
@@ -1900,6 +1921,7 @@ ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),)
   s-intman.adb<libgnarl/s-intman__posix.adb \
   s-osinte.adb<libgnarl/s-osinte__aix.adb \
   s-osinte.ads<libgnarl/s-osinte__aix.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -1941,6 +1963,7 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),)
   s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
   s-intman.adb<libgnarl/s-intman__lynxos.adb \
   s-osinte.adb<libgnarl/s-osinte__lynxos178.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.ads<libgnat/s-osprim__lynxos.ads \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__lynxos.ads \
@@ -1974,6 +1997,7 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),)
   s-intman.ads<libgnarl/s-intman__rtems.ads \
   s-osinte.adb<libgnarl/s-osinte__rtems.adb \
   s-osinte.ads<libgnarl/s-osinte__rtems.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__rtems.adb \
   s-parame.adb<libgnat/s-parame__rtems.adb \
   s-parame.ads<libgnat/s-parame__posix2008.ads \
@@ -2075,6 +2099,7 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
   s-intman.adb<libgnarl/s-intman__mingw.adb \
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__mingw.ads \
+  s-oslock.ads<libgnat/s-oslock__mingw.ads \
   s-osprim.adb<libgnat/s-osprim__mingw.adb \
   s-taprop.adb<libgnarl/s-taprop__mingw.adb
 
@@ -2135,6 +2160,7 @@ ifeq ($(strip $(filter-out loongarch% linux%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2179,6 +2205,7 @@ ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__mips.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2226,6 +2253,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
   s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2272,6 +2300,7 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2312,6 +2341,7 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2346,6 +2376,7 @@ ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__sparc.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2385,6 +2416,7 @@ ifeq ($(strip $(filter-out hppa% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__hppa.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2412,6 +2444,7 @@ ifeq ($(strip $(filter-out m68k% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2439,6 +2472,7 @@ ifeq ($(strip $(filter-out sh4% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2474,6 +2508,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2509,6 +2544,7 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(targe
   s-intman.adb<libgnarl/s-intman__posix.adb \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__hpux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__posix.adb \
   s-taspri.ads<libgnarl/s-taspri__posix.ads \
@@ -2542,6 +2578,7 @@ ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__alpha.ads \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2578,6 +2615,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2622,6 +2660,7 @@ ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),)
   s-mudido.adb<libgnarl/s-mudido__affinity.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
   s-osinte.adb<libgnarl/s-osinte__x32.adb \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__x32.adb \
   s-parame.ads<libgnat/s-parame__posix2008.ads \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
@@ -2661,6 +2700,7 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),)
   s-linux.ads<libgnarl/s-linux__riscv.ads \
   s-osinte.adb<libgnarl/s-osinte__posix.adb \
   s-osinte.ads<libgnarl/s-osinte__linux.ads \
+  s-oslock.ads<libgnat/s-oslock__posix.ads \
   s-osprim.adb<libgnat/s-osprim__posix.adb \
   s-taprop.adb<libgnarl/s-taprop__linux.adb \
   s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
@@ -2699,6 +2739,7 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
     s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
     s-osinte.adb<libgnarl/s-osinte__darwin.adb \
     s-osinte.ads<libgnarl/s-osinte__darwin.ads \
+    s-oslock.ads<libgnat/s-oslock__posix.ads \
     s-taprop.adb<libgnarl/s-taprop__posix.adb \
     s-taspri.ads<libgnarl/s-taspri__posix.ads \
     g-sercom.adb<libgnat/g-sercom__linux.adb \
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 42d18f77771..29249eb4c18 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -4694,6 +4694,8 @@ package body Exp_Ch4 is
                Build_Allocate_Deallocate_Proc (Temp_Decl);
                Rewrite (N, New_Occurrence_Of (Temp, Loc));
                Analyze_And_Resolve (N, PtrT);
+
+               Apply_Predicate_Check (N, Dtyp, Deref => True);
             end;
 
          --  Or else build the fully-fledged initialization if need be
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 993c13c7318..fdacf1cdc01 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -965,6 +965,12 @@ package body Exp_Ch7 is
       if Restriction_Active (No_Finalization) then
          return False;
 
+      --  The System.Finalization_Primitives unit must have been preloaded if
+      --  finalization is really required.
+
+      elsif not RTU_Loaded (System_Finalization_Primitives) then
+         return False;
+
       --  Do not consider C and C++ types since it is assumed that the non-Ada
       --  side will handle their cleanup.
 
@@ -8624,6 +8630,38 @@ package body Exp_Ch7 is
       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
    end Node_To_Be_Wrapped;
 
+   --------------------------------------
+   -- Preload_Finalization_Collection --
+   --------------------------------------
+
+   procedure Preload_Finalization_Collection (Compilation_Unit : Node_Id) is
+   begin
+      --  We can't call RTE (Finalization_Collection) for at least some
+      --  predefined units, because it would introduce cyclic dependences,
+      --  as the type is itself a controlled type.
+      --
+      --  It's only needed when finalization is involved in the unit, which
+      --  requires the presence of controlled or class-wide types in the unit
+      --  (see the Sem_Util.Needs_Finalization predicate for the rationale).
+      --  But controlled types are tagged or contain tagged (sub)components
+      --  so it is sufficient for the parser to detect the "interface" and
+      --  "tagged" keywords.
+      --
+      --  Don't do it if Finalization_Collection is unavailable in the runtime
+
+      if not In_Predefined_Unit (Compilation_Unit)
+        and then (Interface_Seen or else Tagged_Seen)
+        and then not No_Run_Time_Mode
+        and then RTE_Available (RE_Finalization_Collection)
+      then
+         declare
+            Ignore : constant Entity_Id := RTE (RE_Finalization_Collection);
+         begin
+            null;
+         end;
+      end if;
+   end Preload_Finalization_Collection;
+
    ----------------------------
    -- Store_Actions_In_Scope --
    ----------------------------
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 712671a427e..386a02b9283 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -257,6 +257,12 @@ package Exp_Ch7 is
    --  Build a call to suppress the finalization of the object Obj, only after
    --  creating the Master_Node of Obj if it does not already exist.
 
+   procedure Preload_Finalization_Collection (Compilation_Unit : Node_Id);
+   --  Call RTE (RE_Finalization_Collection) if necessary to load the packages
+   --  involved in finalization support. We need to do this explicitly, fairly
+   --  early during compilation, because otherwise it happens during freezing,
+   --  which triggers visibility bugs in generic instantiations.
+
    --------------------------------------------
    -- Task and Protected Object finalization --
    --------------------------------------------
diff --git a/gcc/ada/libgnarl/a-rttiev.adb b/gcc/ada/libgnarl/a-rttiev.adb
index 93bba773fd8..6d0664aecdc 100644
--- a/gcc/ada/libgnarl/a-rttiev.adb
+++ b/gcc/ada/libgnarl/a-rttiev.adb
@@ -29,10 +29,11 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with System.Interrupt_Management.Operations;
+with System.OS_Locks;
+with System.Soft_Links;
 with System.Task_Primitives.Operations;
 with System.Tasking.Utilities;
-with System.Soft_Links;
-with System.Interrupt_Management.Operations;
 
 with Ada.Containers.Doubly_Linked_Lists;
 pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
@@ -61,7 +62,7 @@ package body Ada.Real_Time.Timing_Events is
    --  The queue of pending events, ordered by increasing timeout value, that
    --  have been "set" by the user via Set_Handler.
 
-   Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
+   Event_Queue_Lock : aliased System.OS_Locks.RTS_Lock;
    --  Used for mutually exclusive access to All_Events
 
    --  We need to Initialize_Lock before Timer is activated. The purpose of the
diff --git a/gcc/ada/libgnarl/s-osinte__aix.ads b/gcc/ada/libgnarl/s-osinte__aix.ads
index 9212d33af26..ba61be13131 100644
--- a/gcc/ada/libgnarl/s-osinte__aix.ads
+++ b/gcc/ada/libgnarl/s-osinte__aix.ads
@@ -43,6 +43,7 @@ with Ada.Unchecked_Conversion;
 with Interfaces.C;
 with Interfaces.C.Extensions;
 
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -271,7 +272,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -575,21 +576,6 @@ private
       ptq_prev : ptq_queue_ptr;
    end record;
 
-   type Array_3_Int is array (0 .. 3) of int;
-   type pthread_mutex_t is record
-        link        : ptq_queue;
-        ptmtx_lock  : int;
-        ptmtx_flags : long;
-        protocol    : int;
-        prioceiling : int;
-        ptmtx_owner : pthread_t;
-        mtx_id      : int;
-        attr        : pthread_attr_t;
-        mtx_kind    : int;
-        lock_cpt    : int;
-        reserved    : Array_3_Int;
-   end record;
-   pragma Convention (C, pthread_mutex_t);
    type pthread_mutex_t_ptr is access pthread_mutex_t;
 
    type pthread_cond_t is record
diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads
index ca35aab396f..8e1b5a267b7 100644
--- a/gcc/ada/libgnarl/s-osinte__android.ads
+++ b/gcc/ada/libgnarl/s-osinte__android.ads
@@ -39,9 +39,12 @@
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package.
 
 with Ada.Unchecked_Conversion;
+
 with Interfaces.C;
+
 with System.Linux;
 with System.OS_Constants;
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -271,7 +274,7 @@ package System.OS_Interface is
    function To_pthread_t is
      new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
 
-   type pthread_mutex_t      is limited private;
+   subtype pthread_mutex_t   is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t       is limited private;
    type pthread_attr_t       is limited private;
    type pthread_mutexattr_t  is limited private;
@@ -626,12 +629,6 @@ private
    pragma Convention (C, pthread_mutexattr_t);
    for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
 
-   type pthread_mutex_t is record
-      Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
    type pthread_cond_t is record
       Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
    end record;
diff --git a/gcc/ada/libgnarl/s-osinte__darwin.ads b/gcc/ada/libgnarl/s-osinte__darwin.ads
index af5dce520c5..0ffa18b481a 100644
--- a/gcc/ada/libgnarl/s-osinte__darwin.ads
+++ b/gcc/ada/libgnarl/s-osinte__darwin.ads
@@ -39,7 +39,9 @@
 --  Elaborate_Body. It is designed to be a bottom-level (leaf) package.
 
 with Interfaces.C;
+
 with System.OS_Constants;
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -244,7 +246,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -571,12 +573,6 @@ private
    end record;
    pragma Convention (C, pthread_mutexattr_t);
 
-   type pthread_mutex_t is record
-      sig    : long;
-      opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE);
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-
    type pthread_condattr_t is record
       sig    : long;
       opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE);
diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.ads b/gcc/ada/libgnarl/s-osinte__dragonfly.ads
index bf078ddbd41..e34c7fb7cc9 100644
--- a/gcc/ada/libgnarl/s-osinte__dragonfly.ads
+++ b/gcc/ada/libgnarl/s-osinte__dragonfly.ads
@@ -43,6 +43,7 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -278,7 +279,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -646,7 +647,6 @@ private
 
    type pthread_t           is new System.Address;
    type pthread_attr_t      is new System.Address;
-   type pthread_mutex_t     is new System.Address;
    type pthread_mutexattr_t is new System.Address;
    type pthread_cond_t      is new System.Address;
    type pthread_condattr_t  is new System.Address;
diff --git a/gcc/ada/libgnarl/s-osinte__freebsd.ads b/gcc/ada/libgnarl/s-osinte__freebsd.ads
index 8724ddc504f..bda06b9c5fe 100644
--- a/gcc/ada/libgnarl/s-osinte__freebsd.ads
+++ b/gcc/ada/libgnarl/s-osinte__freebsd.ads
@@ -43,6 +43,7 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -280,7 +281,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -643,7 +644,6 @@ private
 
    type pthread_t           is new System.Address;
    type pthread_attr_t      is new System.Address;
-   type pthread_mutex_t     is new System.Address;
    type pthread_mutexattr_t is new System.Address;
    type pthread_cond_t      is new System.Address;
    type pthread_condattr_t  is new System.Address;
diff --git a/gcc/ada/libgnarl/s-osinte__gnu.ads b/gcc/ada/libgnarl/s-osinte__gnu.ads
index 8e5760dc99a..62645b6d44b 100644
--- a/gcc/ada/libgnarl/s-osinte__gnu.ads
+++ b/gcc/ada/libgnarl/s-osinte__gnu.ads
@@ -38,9 +38,12 @@
 --  PLEASE DO NOT add any with-clauses to this package or remove the pragma
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package
 
+with Ada.Unchecked_Conversion;
+
 with Interfaces.C;
+
+with System.OS_Locks;
 with System.Parameters;
-with Ada.Unchecked_Conversion;
 
 package System.OS_Interface is
    pragma Preelaborate;
@@ -298,14 +301,14 @@ package System.OS_Interface is
    function To_pthread_t is new Ada.Unchecked_Conversion
      (unsigned_long, pthread_t);
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_rwlock_t     is limited private;
-   type pthread_cond_t      is limited private;
-   type pthread_attr_t      is limited private;
-   type pthread_mutexattr_t is limited private;
+   type pthread_cond_t       is limited private;
+   type pthread_attr_t       is limited private;
+   type pthread_mutexattr_t  is limited private;
    type pthread_rwlockattr_t is limited private;
-   type pthread_condattr_t  is limited private;
-   type pthread_key_t       is private;
+   type pthread_condattr_t   is limited private;
+   type pthread_key_t        is private;
 
    --  From /usr/include/pthread/pthreadtypes.h
    PTHREAD_CREATE_DETACHED : constant := 1;
@@ -712,39 +715,6 @@ private
    end record;
    pragma Convention (C, pthread_mutexattr_t);
 
-   --  From: /usr/include/pthread/pthreadtypes.h
-   --  typedef struct __pthread_mutex pthread_mutex_t; and
-   --  /usr/include/i386-gnu/bits/mutex.h:
-   --  struct __pthread_mutex {
-   --  __pthread_spinlock_t __held;
-   --  __pthread_spinlock_t __lock;
-   --  /* in cthreads, mutex_init does not initialized the third
-   --    pointer, as such, we cannot rely on its value for anything.  */
-   --    char *cthreadscompat1;
-   --  struct __pthread *__queue;
-   --  struct __pthread_mutexattr *attr;
-   --  void *data;
-   --  /*  up to this point, we are completely compatible with cthreads
-   --    and what libc expects.  */
-   --    void *owner;
-   --  unsigned locks;
-   --  /* if null then the default attributes apply.  */
-   --    };
-
-   type pthread_mutex_t is record
-      held          : int;
-      lock          : int;
-      cthreadcompat : System.Address;
-      queue         : System.Address;
-      attr          : System.Address;
-      data          : System.Address;
-      owner         : System.Address;
-      locks         : unsigned;
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   --  pointer needed?
-   --  type pthread_mutex_t_ptr is access pthread_mutex_t;
-
    --  From: /usr/include/pthread/pthreadtypes.h:
    --  typedef struct __pthread_cond pthread_cond_t;
    --  typedef struct __pthread_condattr pthread_condattr_t;
diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
index b1ccd96c0ca..364a5ecbd52 100644
--- a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
+++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads
@@ -42,6 +42,7 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -239,7 +240,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -478,9 +479,6 @@ private
    type pthread_t is new cma_t_handle;
    pragma Convention (C_Pass_By_Copy, pthread_t);
 
-   type pthread_mutex_t is new cma_t_handle;
-   pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
-
    type pthread_cond_t is new cma_t_handle;
    pragma Convention (C_Pass_By_Copy, pthread_cond_t);
 
diff --git a/gcc/ada/libgnarl/s-osinte__hpux.ads b/gcc/ada/libgnarl/s-osinte__hpux.ads
index 52d599589c0..5d3d35240c3 100644
--- a/gcc/ada/libgnarl/s-osinte__hpux.ads
+++ b/gcc/ada/libgnarl/s-osinte__hpux.ads
@@ -42,6 +42,7 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -252,7 +253,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -533,26 +534,6 @@ private
    type short_array is array (Natural range <>) of short;
    type int_array is array (Natural range <>) of int;
 
-   type pthread_mutex_t is record
-      m_short : short_array (0 .. 1);
-      m_int   : int;
-      m_int1  : int_array (0 .. 3);
-      m_pad   : int;
-
-      m_ptr : int;
-      --  actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that
-      --  this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is
-      --  a 64 bit void*. Assume int'Size = 32.
-
-      m_int2   : int_array (0 .. 1);
-      m_int3   : int_array (0 .. 3);
-      m_short2 : short_array (0 .. 1);
-      m_int4   : int_array (0 .. 4);
-      m_int5   : int_array (0 .. 1);
-   end record;
-   for pthread_mutex_t'Alignment use System.Address'Alignment;
-   pragma Convention (C, pthread_mutex_t);
-
    type pthread_cond_t is record
       c_short : short_array (0 .. 1);
       c_int   : int;
diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
index 93837596946..5725a1115bd 100644
--- a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
+++ b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads
@@ -39,7 +39,10 @@
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package
 
 with Ada.Unchecked_Conversion;
+
 with Interfaces.C;
+
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -284,7 +287,7 @@ package System.OS_Interface is
    function To_pthread_t is new Ada.Unchecked_Conversion
      (unsigned_long, pthread_t);
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -637,15 +640,6 @@ private
    end record;
    pragma Convention (C, struct_pthread_fast_lock);
 
-   type pthread_mutex_t is record
-      m_reserved : int;
-      m_count    : int;
-      m_owner    : System.Address;
-      m_kind     : int;
-      m_lock     : struct_pthread_fast_lock;
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-
    type pthread_cond_t is array (0 .. 47) of unsigned_char;
    pragma Convention (C, pthread_cond_t);
 
diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads
index 1bf4d960c39..71788be0431 100644
--- a/gcc/ada/libgnarl/s-osinte__linux.ads
+++ b/gcc/ada/libgnarl/s-osinte__linux.ads
@@ -39,9 +39,12 @@
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package.
 
 with Ada.Unchecked_Conversion;
+
 with Interfaces.C;
+
 with System.Linux;
 with System.OS_Constants;
+with System.OS_Locks;
 
 package System.OS_Interface is
    pragma Preelaborate;
@@ -301,7 +304,7 @@ package System.OS_Interface is
    function To_pthread_t is
      new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
 
-   type pthread_mutex_t      is limited private;
+   subtype pthread_mutex_t   is System.OS_Locks.pthread_mutex_t;
    type pthread_rwlock_t     is limited private;
    type pthread_cond_t       is limited private;
    type pthread_attr_t       is limited private;
@@ -656,12 +659,6 @@ private
    pragma Convention (C, pthread_mutexattr_t);
    for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
 
-   type pthread_mutex_t is record
-      Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
    type pthread_rwlockattr_t is record
       Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
    end record;
diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
index 23ea89a821a..d9f2f121a78 100644
--- a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
+++ b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads
@@ -43,6 +43,7 @@ with Ada.Unchecked_Conversion;
 with Interfaces.C;
 
 with System.Multiprocessors;
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -267,7 +268,7 @@ package System.OS_Interface is
 
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t     is limited private;
+   subtype pthread_mutex_t  is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t      is limited private;
    type pthread_attr_t      is limited private;
    type pthread_mutexattr_t is limited private;
@@ -597,18 +598,6 @@ private
    end record;
    pragma Convention (C, block_obj_t);
 
-   type pthread_mutex_t is record
-      m_flags      : unsigned;
-      m_owner      : tid_t;
-      m_wait       : block_obj_t;
-      m_prio_c     : int;
-      m_oldprio    : int;
-      m_count      : int;
-      m_referenced : int;
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   type pthread_mutex_t_ptr is access all pthread_mutex_t;
-
    type pthread_cond_t is record
       cv_magic   : unsigned;
       cv_wait    : block_obj_t;
diff --git a/gcc/ada/libgnarl/s-osinte__mingw.ads b/gcc/ada/libgnarl/s-osinte__mingw.ads
index 4be6c03a149..575eb351e70 100644
--- a/gcc/ada/libgnarl/s-osinte__mingw.ads
+++ b/gcc/ada/libgnarl/s-osinte__mingw.ads
@@ -43,6 +43,8 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 with Interfaces.C.Strings;
+
+with System.OS_Locks;
 with System.Win32;
 
 package System.OS_Interface is
@@ -144,7 +146,24 @@ package System.OS_Interface is
    -- Critical sections --
    -----------------------
 
-   type CRITICAL_SECTION is private;
+   subtype CRITICAL_SECTION is System.OS_Locks.CRITICAL_SECTION;
+
+   procedure InitializeCriticalSection
+     (pCriticalSection : access CRITICAL_SECTION);
+   pragma Import
+     (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+   procedure EnterCriticalSection
+     (pCriticalSection : access CRITICAL_SECTION);
+   pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+   procedure LeaveCriticalSection
+     (pCriticalSection : access CRITICAL_SECTION);
+   pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+   procedure DeleteCriticalSection
+     (pCriticalSection : access CRITICAL_SECTION);
+   pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
 
    -------------------------------------------------------------
    -- Thread Creation, Activation, Suspension And Termination --
@@ -359,17 +378,4 @@ private
 
    type sigset_t is new Interfaces.C.unsigned_long;
 
-   type CRITICAL_SECTION is record
-      DebugInfo : System.Address;
-
-      LockCount      : Long_Integer;
-      RecursionCount : Long_Integer;
-      OwningThread   : Win32.HANDLE;
-      --  The above three fields control entering and exiting the critical
-      --  section for the resource.
-
-      LockSemaphore : Win32.HANDLE;
-      SpinCount     : Interfaces.C.size_t;
-   end record;
-
 end System.OS_Interface;
diff --git a/gcc/ada/libgnarl/s-osinte__qnx.ads b/gcc/ada/libgnarl/s-osinte__qnx.ads
index b1de1c6f24e..91b1d18739d 100644
--- a/gcc/ada/libgnarl/s-osinte__qnx.ads
+++ b/gcc/ada/libgnarl/s-osinte__qnx.ads
@@ -38,8 +38,11 @@
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package.
 
 with Ada.Unchecked_Conversion;
+
 with Interfaces.C;
+
 with System.OS_Constants;
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -268,7 +271,7 @@ package System.OS_Interface is
    type pthread_t is new int;
    subtype Thread_Id is pthread_t;
 
-   type pthread_mutex_t      is limited private;
+   subtype pthread_mutex_t   is System.OS_Locks.pthread_mutex_t;
    type pthread_cond_t       is limited private;
    type pthread_attr_t       is limited private;
    type pthread_mutexattr_t  is limited private;
@@ -283,7 +286,7 @@ package System.OS_Interface is
    PTHREAD_INHERIT_SCHED  : constant := 0;
    PTHREAD_EXPLICIT_SCHED : constant := 2;
 
-   --  Read/Write lock not supported on Android.
+   --  Read/Write lock not supported on QNX
 
    subtype pthread_rwlock_t     is pthread_mutex_t;
    subtype pthread_rwlockattr_t is pthread_mutexattr_t;
@@ -601,12 +604,6 @@ private
    pragma Convention (C, pthread_mutexattr_t);
    for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
 
-   type pthread_mutex_t is record
-      Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
    type pthread_cond_t is record
       Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
    end record;
diff --git a/gcc/ada/libgnarl/s-osinte__rtems.ads b/gcc/ada/libgnarl/s-osinte__rtems.ads
index 6a7487c5db3..de7174c23cd 100644
--- a/gcc/ada/libgnarl/s-osinte__rtems.ads
+++ b/gcc/ada/libgnarl/s-osinte__rtems.ads
@@ -51,7 +51,9 @@
 --  It is designed to be a bottom-level (leaf) package.
 
 with Interfaces.C;
+
 with System.OS_Constants;
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -247,7 +249,7 @@ package System.OS_Interface is
    type pthread_t           is private;
    subtype Thread_Id        is pthread_t;
 
-   type pthread_mutex_t      is limited private;
+   subtype pthread_mutex_t   is System.OS_Locks.pthread_mutex_t;
    type pthread_rwlock_t     is limited private;
    type pthread_cond_t       is limited private;
    type pthread_attr_t       is limited private;
@@ -629,12 +631,6 @@ private
 
    type pthread_t is new rtems_id;
 
-   type pthread_mutex_t is record
-      Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
-   end record;
-   pragma Convention (C, pthread_mutex_t);
-   for pthread_mutex_t'Alignment use Interfaces.C.double'Alignment;
-
    type pthread_rwlock_t is record
       Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
    end record;
diff --git a/gcc/ada/libgnarl/s-osinte__solaris.ads b/gcc/ada/libgnarl/s-osinte__solaris.ads
index a7ee96d750f..12ad52bb48e 100644
--- a/gcc/ada/libgnarl/s-osinte__solaris.ads
+++ b/gcc/ada/libgnarl/s-osinte__solaris.ads
@@ -38,10 +38,11 @@
 --  PLEASE DO NOT add any with-clauses to this package or remove the pragma
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package.
 
-with Interfaces.C;
-
 with Ada.Unchecked_Conversion;
 
+with Interfaces.C;
+
+with System.OS_Locks;
 with System.Parameters;
 
 package System.OS_Interface is
@@ -297,7 +298,7 @@ package System.OS_Interface is
 
    function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
 
-   type mutex_t is limited private;
+   subtype mutex_t is System.OS_Lock.mutex_t;
 
    type cond_t is limited private;
 
@@ -543,13 +544,6 @@ private
 
    type upad64_t is new Interfaces.Unsigned_64;
 
-   type mutex_t is record
-      flags : record_type_3;
-      lock  : upad64_t;
-      data  : upad64_t;
-   end record;
-   pragma Convention (C, mutex_t);
-
    type cond_t is record
       flags : record_type_3;
       data  : upad64_t;
diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.ads b/gcc/ada/libgnarl/s-osinte__vxworks.ads
index 5e4e8ce912c..00e9e2dca4f 100644
--- a/gcc/ada/libgnarl/s-osinte__vxworks.ads
+++ b/gcc/ada/libgnarl/s-osinte__vxworks.ads
@@ -39,6 +39,7 @@
 --  Preelaborate. This package is designed to be a bottom-level (leaf) package.
 
 with Interfaces.C;
+
 with System.VxWorks;
 with System.VxWorks.Ext;
 with System.Multiprocessors;
diff --git a/gcc/ada/libgnarl/s-taprop.ads b/gcc/ada/libgnarl/s-taprop.ads
index c4920e3158c..35f0ea417f8 100644
--- a/gcc/ada/libgnarl/s-taprop.ads
+++ b/gcc/ada/libgnarl/s-taprop.ads
@@ -32,15 +32,15 @@
 --  This package contains all the GNULL primitives that interface directly with
 --  the underlying OS.
 
+with System.OS_Interface;
 with System.Parameters;
 with System.Tasking;
-with System.OS_Interface;
 
 package System.Task_Primitives.Operations is
    pragma Preelaborate;
 
-   package ST renames System.Tasking;
    package OSI renames System.OS_Interface;
+   package ST  renames System.Tasking;
 
    procedure Initialize (Environment_Task : ST.Task_Id);
    --  Perform initialization and set up of the environment task for proper
@@ -149,7 +149,7 @@ package System.Task_Primitives.Operations is
      (Prio : System.Any_Priority;
       L    : not null access Lock);
    procedure Initialize_Lock
-     (L     : not null access RTS_Lock;
+     (L     : not null access System.OS_Locks.RTS_Lock;
       Level : Lock_Level);
    pragma Inline (Initialize_Lock);
    --  Initialize a lock object
@@ -173,7 +173,7 @@ package System.Task_Primitives.Operations is
    --  These operations raise Storage_Error if a lack of storage is detected
 
    procedure Finalize_Lock (L : not null access Lock);
-   procedure Finalize_Lock (L : not null access RTS_Lock);
+   procedure Finalize_Lock (L : not null access System.OS_Locks.RTS_Lock);
    pragma Inline (Finalize_Lock);
    --  Finalize a lock object, freeing any resources allocated by the
    --  corresponding Initialize_Lock operation.
@@ -181,7 +181,7 @@ package System.Task_Primitives.Operations is
    procedure Write_Lock
      (L                 : not null access Lock;
       Ceiling_Violation : out Boolean);
-   procedure Write_Lock (L : not null access RTS_Lock);
+   procedure Write_Lock (L : not null access System.OS_Locks.RTS_Lock);
    procedure Write_Lock (T : ST.Task_Id);
    pragma Inline (Write_Lock);
    --  Lock a lock object for write access. After this operation returns,
@@ -229,7 +229,7 @@ package System.Task_Primitives.Operations is
 
    procedure Unlock
      (L : not null access Lock);
-   procedure Unlock (L : not null access RTS_Lock);
+   procedure Unlock (L : not null access System.OS_Locks.RTS_Lock);
    procedure Unlock (T : ST.Task_Id);
    pragma Inline (Unlock);
    --  Unlock a locked lock object
diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb
index 829d595694c..68ec8b448ba 100644
--- a/gcc/ada/libgnarl/s-taprop__dummy.adb
+++ b/gcc/ada/libgnarl/s-taprop__dummy.adb
@@ -36,8 +36,9 @@
 
 package body System.Task_Primitives.Operations is
 
-   use System.Tasking;
+   use System.OS_Locks;
    use System.Parameters;
+   use System.Tasking;
 
    pragma Warnings (Off);
    --  Turn off warnings since so many unreferenced parameters
diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
index fb95f768313..7f4e707645d 100644
--- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
+++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb
@@ -38,11 +38,11 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
-with System.Tasking.Debug;
 with System.Interrupt_Management;
 with System.OS_Constants;
 with System.OS_Primitives;
 with System.Task_Primitives.Interrupt_Operations;
+with System.Tasking.Debug;
 
 pragma Warnings (Off);
 with System.Interrupt_Management.Operations;
@@ -60,12 +60,14 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use Interfaces.C;
+
    use System.OS_Interface;
-   use System.Parameters;
+   use System.OS_Locks;
    use System.OS_Primitives;
+   use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
 
    package PIO renames System.Task_Primitives.Interrupt_Operations;
 
diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb
index 74717cb2d2b..1faa3d8914e 100644
--- a/gcc/ada/libgnarl/s-taprop__linux.adb
+++ b/gcc/ada/libgnarl/s-taprop__linux.adb
@@ -34,14 +34,14 @@
 --  This package contains all the GNULL primitives that interface directly with
 --  the underlying OS.
 
-with Interfaces.C; use Interfaces; use type Interfaces.C.int;
+with Interfaces.C;
 
-with System.Task_Info;
-with System.Tasking.Debug;
 with System.Interrupt_Management;
+with System.Multiprocessors;
 with System.OS_Constants;
 with System.OS_Primitives;
-with System.Multiprocessors;
+with System.Task_Info;
+with System.Tasking.Debug;
 
 with System.Soft_Links;
 --  We use System.Soft_Links instead of System.Tasking.Initialization
@@ -54,12 +54,17 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
-   use System.OS_Interface;
+   use Interfaces;
+
    use System.Parameters;
+   use System.OS_Interface;
+   use System.OS_Locks;
    use System.OS_Primitives;
    use System.Task_Info;
+   use System.Tasking.Debug;
+   use System.Tasking;
+
+   use type Interfaces.C.int;
 
    ----------------
    -- Local Data --
diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb
index e97682e4f79..df1cb67b707 100644
--- a/gcc/ada/libgnarl/s-taprop__mingw.adb
+++ b/gcc/ada/libgnarl/s-taprop__mingw.adb
@@ -57,7 +57,9 @@ package body System.Task_Primitives.Operations is
 
    use Interfaces.C;
    use Interfaces.C.Strings;
+
    use System.OS_Interface;
+   use System.OS_Locks;
    use System.OS_Primitives;
    use System.Parameters;
    use System.Task_Info;
@@ -73,30 +75,6 @@ package body System.Task_Primitives.Operations is
    --  Also note that under Windows XP, we use a Windows XP extension to
    --  specify the stack size on a per task basis, as done under other OSes.
 
-   ---------------------
-   -- Local Functions --
-   ---------------------
-
-   procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
-   procedure InitializeCriticalSection
-     (pCriticalSection : access CRITICAL_SECTION);
-   pragma Import
-     (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
-
-   procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
-   procedure EnterCriticalSection
-     (pCriticalSection : access CRITICAL_SECTION);
-   pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
-
-   procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
-   procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
-   pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
-
-   procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
-   procedure DeleteCriticalSection
-     (pCriticalSection : access CRITICAL_SECTION);
-   pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
-
    ----------------
    -- Local Data --
    ----------------
@@ -421,7 +399,8 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
    is
       pragma Unreferenced (Level);
    begin
diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb
index a71e42112ac..7ed52ea2d82 100644
--- a/gcc/ada/libgnarl/s-taprop__posix.adb
+++ b/gcc/ada/libgnarl/s-taprop__posix.adb
@@ -44,11 +44,11 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
-with System.Tasking.Debug;
 with System.Interrupt_Management;
 with System.OS_Constants;
 with System.OS_Primitives;
 with System.Task_Info;
+with System.Tasking.Debug;
 
 with System.Soft_Links;
 --  We use System.Soft_Links instead of System.Tasking.Initialization
@@ -61,12 +61,14 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use Interfaces.C;
+
    use System.OS_Interface;
-   use System.Parameters;
+   use System.OS_Locks;
    use System.OS_Primitives;
+   use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
 
    ----------------
    -- Local Data --
diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index 2f11d2821fb..108180d0617 100644
--- a/gcc/ada/libgnarl/s-taprop__qnx.adb
+++ b/gcc/ada/libgnarl/s-taprop__qnx.adb
@@ -44,12 +44,12 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
-with System.Tasking.Debug;
 with System.Interrupt_Management;
+with System.Multiprocessors;
 with System.OS_Constants;
 with System.OS_Primitives;
 with System.Task_Info;
-with System.Multiprocessors;
+with System.Tasking.Debug;
 
 with System.Soft_Links;
 --  We use System.Soft_Links instead of System.Tasking.Initialization
@@ -62,12 +62,14 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use Interfaces.C;
+
    use System.OS_Interface;
-   use System.Parameters;
+   use System.OS_Locks;
    use System.OS_Primitives;
+   use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
 
    ----------------
    -- Local Data --
diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb
index b041592cbe0..3feafd8bc3a 100644
--- a/gcc/ada/libgnarl/s-taprop__rtems.adb
+++ b/gcc/ada/libgnarl/s-taprop__rtems.adb
@@ -38,11 +38,11 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
-with System.Tasking.Debug;
 with System.Interrupt_Management;
 with System.OS_Constants;
 with System.OS_Primitives;
 with System.Task_Info;
+with System.Tasking.Debug;
 
 with System.Soft_Links;
 --  We use System.Soft_Links instead of System.Tasking.Initialization
@@ -55,12 +55,14 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use Interfaces.C;
+
    use System.OS_Interface;
-   use System.Parameters;
+   use System.OS_Locks;
    use System.OS_Primitives;
+   use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
 
    ----------------
    -- Local Data --
diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb
index 657ad555814..88b77b09820 100644
--- a/gcc/ada/libgnarl/s-taprop__solaris.adb
+++ b/gcc/ada/libgnarl/s-taprop__solaris.adb
@@ -36,12 +36,12 @@
 
 with Interfaces.C;
 
-with System.Multiprocessors;
-with System.Tasking.Debug;
 with System.Interrupt_Management;
+with System.Multiprocessors;
 with System.OS_Constants;
 with System.OS_Primitives;
 with System.Task_Info;
+with System.Tasking.Debug;
 
 pragma Warnings (Off);
 with System.OS_Lib;
@@ -58,12 +58,14 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use Interfaces.C;
+
    use System.OS_Interface;
-   use System.Parameters;
+   use System.OS_Locks;
    use System.OS_Primitives;
+   use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
 
    ----------------
    -- Local Data --
diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb
index 8b146f9a326..feafab4257b 100644
--- a/gcc/ada/libgnarl/s-taprop__vxworks.adb
+++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb
@@ -38,11 +38,11 @@ with Ada.Unchecked_Conversion;
 
 with Interfaces.C;
 
-with System.Multiprocessors;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
 with System.Float_Control;
+with System.Interrupt_Management;
+with System.Multiprocessors;
 with System.OS_Constants;
+with System.Tasking.Debug;
 
 with System.Soft_Links;
 --  We use System.Soft_Links instead of System.Tasking.Initialization
@@ -58,10 +58,12 @@ package body System.Task_Primitives.Operations is
    package OSC renames System.OS_Constants;
    package SSL renames System.Soft_Links;
 
-   use System.Tasking.Debug;
-   use System.Tasking;
    use System.OS_Interface;
+   use System.OS_Locks;
    use System.Parameters;
+   use System.Tasking;
+   use System.Tasking.Debug;
+
    use type Interfaces.C.int;
    use type System.OS_Interface.unsigned;
    use type System.VxWorks.Ext.t_id;
diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb
index 98ceb8f852a..5c2ee90e84b 100644
--- a/gcc/ada/libgnarl/s-tarest.adb
+++ b/gcc/ada/libgnarl/s-tarest.adb
@@ -41,8 +41,9 @@ pragma Style_Checks (All_Checks);
 
 with Ada.Exceptions;
 
-with System.Task_Primitives.Operations;
+with System.OS_Locks;
 with System.Soft_Links.Tasking;
+with System.Task_Primitives.Operations;
 
 with System.Soft_Links;
 --  Used for the non-tasking routines (*_NT) that refer to global data. They
@@ -63,7 +64,7 @@ package body System.Tasking.Restricted.Stages is
    Tasks_Activation_Chain : Task_Id;
    --  Chain of all the tasks to activate
 
-   Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
+   Global_Task_Lock : aliased System.OS_Locks.RTS_Lock;
    --  This is a global lock; it is used to execute in mutual exclusion
    --  from all other tasks. It is only used by Task_Lock and Task_Unlock.
 
diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb
index 8bb42d9f939..22294145bed 100644
--- a/gcc/ada/libgnarl/s-tasini.adb
+++ b/gcc/ada/libgnarl/s-tasini.adb
@@ -33,10 +33,11 @@ pragma Style_Checks (All_Checks);
 --  Turn off subprogram alpha ordering check, since we group soft link bodies
 --  and dummy soft link bodies together separately in this unit.
 
-with System.Task_Primitives;
-with System.Task_Primitives.Operations;
+with System.OS_Locks;
 with System.Soft_Links;
 with System.Soft_Links.Tasking;
+with System.Task_Primitives;
+with System.Task_Primitives.Operations;
 with System.Tasking.Debug;
 with System.Tasking.Task_Attributes;
 
@@ -48,13 +49,14 @@ pragma Unreferenced (System.Secondary_Stack);
 
 package body System.Tasking.Initialization is
 
-   package STPO renames System.Task_Primitives.Operations;
+   package SOL  renames System.OS_Locks;
    package SSL  renames System.Soft_Links;
+   package STPO renames System.Task_Primitives.Operations;
 
    use Parameters;
    use Task_Primitives.Operations;
 
-   Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
+   Global_Task_Lock : aliased SOL.RTS_Lock;
    --  This is a global lock; it is used to execute in mutual exclusion from
    --  all other tasks. It is only used by Task_Lock, Task_Unlock, and
    --  Final_Task_Unlock.
@@ -88,6 +90,18 @@ package body System.Tasking.Initialization is
    function Task_Name return String;
    --  Returns current task's name
 
+   procedure Initialize_RTS_Lock (Addr : Address);
+   --  Initialize the RTS lock at Addr
+
+   procedure Finalize_RTS_Lock (Addr : Address);
+   --  Finalize the RTS lock at Addr
+
+   procedure Acquire_RTS_Lock (Addr : Address);
+   --  Acquire the RTS lock at Addr
+
+   procedure Release_RTS_Lock (Addr : Address);
+   --  Release the RTS lock at Addr
+
    ------------------------
    --  Local Subprograms --
    ------------------------
@@ -220,6 +234,54 @@ package body System.Tasking.Initialization is
       return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
    end Get_Current_Excep;
 
+   -------------------------
+   -- Initialize_RTS_Lock --
+   -------------------------
+
+   procedure Initialize_RTS_Lock (Addr : Address) is
+      Lock : aliased SOL.RTS_Lock;
+      for Lock'Address use Addr;
+
+   begin
+      Initialize_Lock (Lock'Unchecked_Access, PO_Level);
+   end Initialize_RTS_Lock;
+
+   -----------------------
+   -- Finalize_RTS_Lock --
+   -----------------------
+
+   procedure Finalize_RTS_Lock (Addr : Address) is
+      Lock : aliased SOL.RTS_Lock;
+      for Lock'Address use Addr;
+
+   begin
+      Finalize_Lock (Lock'Unchecked_Access);
+   end Finalize_RTS_Lock;
+
+   ----------------------
+   -- Acquire_RTS_Lock --
+   ----------------------
+
+   procedure Acquire_RTS_Lock (Addr : Address) is
+      Lock : aliased SOL.RTS_Lock;
+      for Lock'Address use Addr;
+
+   begin
+      Write_Lock (Lock'Unchecked_Access);
+   end Acquire_RTS_Lock;
+
+   ----------------------
+   -- Release_RTS_Lock --
+   ----------------------
+
+   procedure Release_RTS_Lock (Addr : Address) is
+      Lock : aliased SOL.RTS_Lock;
+      for Lock'Address use Addr;
+
+   begin
+      Unlock (Lock'Unchecked_Access);
+   end Release_RTS_Lock;
+
    -----------------------
    -- Do_Pending_Action --
    -----------------------
@@ -352,6 +414,11 @@ package body System.Tasking.Initialization is
       SSL.Task_Name          := Task_Name'Access;
       SSL.Get_Current_Excep  := Get_Current_Excep'Access;
 
+      SSL.Initialize_RTS_Lock := Initialize_RTS_Lock'Access;
+      SSL.Finalize_RTS_Lock   := Finalize_RTS_Lock'Access;
+      SSL.Acquire_RTS_Lock    := Acquire_RTS_Lock'Access;
+      SSL.Release_RTS_Lock    := Release_RTS_Lock'Access;
+
       --  Initialize the tasking soft links (if not done yet) that are common
       --  to the full and the restricted run times.
 
diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads
index 4b25f1975c2..58a250d52a0 100644
--- a/gcc/ada/libgnarl/s-taspri__dummy.ads
+++ b/gcc/ada/libgnarl/s-taspri__dummy.ads
@@ -31,13 +31,13 @@
 
 --  This is a no tasking version of this package
 
+with System.OS_Locks;
+
 package System.Task_Primitives is
    pragma Preelaborate;
 
    type Lock is new Integer;
 
-   type RTS_Lock is new Integer;
-
    type Suspension_Object is new Integer;
 
    type Task_Body_Access is access procedure;
@@ -45,7 +45,7 @@ package System.Task_Primitives is
    type Private_Data is limited record
       Thread : aliased Integer;
       CV     : aliased Integer;
-      L      : aliased RTS_Lock;
+      L      : aliased System.OS_Locks.RTS_Lock;
    end record;
 
    subtype Task_Address is System.Address;
diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
index f2fba3eda92..9ec5dcbfd98 100644
--- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
+++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads
@@ -34,6 +34,7 @@
 --  This package provides low-level support for most tasking features
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -41,11 +42,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the later one serves only as a semaphore so
-   --  that do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -67,13 +63,11 @@ package System.Task_Primitives is
 
 private
    type Lock is record
-      L              : aliased System.OS_Interface.pthread_mutex_t;
+      L              : aliased System.OS_Locks.RTS_Lock;
       Priority       : Integer;
       Owner_Priority : Integer;
    end record;
 
-   type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
    type Suspension_Object is record
       State   : Boolean;
       pragma Atomic (State);
@@ -84,7 +78,7 @@ private
       Waiting : Boolean;
       --  Flag showing if there is a task already suspended on this object
 
-      L : aliased System.OS_Interface.pthread_mutex_t;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for ensuring mutual exclusion on the Suspension_Object
 
       CV : aliased System.OS_Interface.pthread_cond_t;
@@ -103,8 +97,9 @@ private
       --  are updated in atomic fashion.
 
       CV : aliased System.OS_Interface.pthread_cond_t;
+      --  Condition variable used to queue threads until condition is signaled
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads
index 07d9be28bb8..a3307000c80 100644
--- a/gcc/ada/libgnarl/s-taspri__lynxos.ads
+++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads
@@ -33,6 +33,7 @@
 --  This is LynxOS Family version of this package.
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -40,11 +41,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the latter serves only as a semaphore so that
-   --  we do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -68,11 +64,9 @@ private
 
    type Lock is record
       RW : aliased System.OS_Interface.pthread_rwlock_t;
-      WO : aliased System.OS_Interface.pthread_mutex_t;
+      WO : aliased System.OS_Locks.RTS_Lock;
    end record;
 
-   type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
    type Suspension_Object is record
       State : Boolean;
       pragma Atomic (State);
@@ -83,7 +77,7 @@ private
       Waiting : Boolean;
       --  Flag showing if there is a task already suspended on this object
 
-      L : aliased System.OS_Interface.pthread_mutex_t;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for ensuring mutual exclusion on the Suspension_Object
 
       CV : aliased System.OS_Interface.pthread_cond_t;
@@ -105,9 +99,9 @@ private
       --  On targets where lwp is not relevant, this is equivalent to Thread.
 
       CV : aliased System.OS_Interface.pthread_cond_t;
-      --  Should be commented ??? (in all versions of taspri)
+      --  Condition variable used to queue threads until condition is signaled
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads
index 426c4a3ffde..a51f752d805 100644
--- a/gcc/ada/libgnarl/s-taspri__mingw.ads
+++ b/gcc/ada/libgnarl/s-taspri__mingw.ads
@@ -31,7 +31,7 @@
 
 --  This is a NT (native) version of this package
 
-with System.OS_Interface;
+with System.OS_Locks;
 with System.Win32;
 
 package System.Task_Primitives is
@@ -40,11 +40,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the later one serves only as a semaphore so
-   --  that do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -67,15 +62,13 @@ package System.Task_Primitives is
 private
 
    type Lock is record
-      Mutex          : aliased System.OS_Interface.CRITICAL_SECTION;
+      Mutex          : aliased System.OS_Locks.RTS_Lock;
       Priority       : Integer;
       Owner_Priority : Integer;
    end record;
 
    type Condition_Variable is new System.Win32.HANDLE;
 
-   type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
-
    type Suspension_Object is record
       State : Boolean;
       pragma Atomic (State);
@@ -86,7 +79,7 @@ private
       Waiting : Boolean;
       --  Flag showing if there is a task already suspended on this object
 
-      L : aliased System.OS_Interface.CRITICAL_SECTION;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for ensuring mutual exclusion on the Suspension_Object
 
       CV : aliased Win32.HANDLE;
@@ -108,7 +101,7 @@ private
       CV : aliased Condition_Variable;
       --  Condition Variable used to implement Sleep/Wakeup
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
index f9118c738a2..b92f1dd4ab2 100644
--- a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads
@@ -1,12 +1,12 @@
 ------------------------------------------------------------------------------
 --                                                                          --
---                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
 --                                                                          --
---                 S Y S T E M . T A S K _ P R I M I T I V E S              --
+--               S Y S T E M . T A S K _ P R I M I T I V E S                --
 --                                                                          --
---                                  S p e c                                 --
+--                                 S p e c                                  --
 --                                                                          --
---             Copyright (C) 1991-2017, Florida State University            --
+--            Copyright (C) 1991-2017, Florida State University             --
 --                     Copyright (C) 1995-2024, AdaCore                     --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
@@ -36,6 +36,7 @@
 --  Note: this file can only be used for POSIX compliant systems
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -43,11 +44,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the later one serves only as a semaphore so
-   --  that do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -69,11 +65,9 @@ package System.Task_Primitives is
 
 private
 
-   type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
    type Lock is record
-      WO : aliased RTS_Lock;
       RW : aliased System.OS_Interface.pthread_rwlock_t;
+      WO : aliased System.OS_Locks.RTS_Lock;
    end record;
 
    type Suspension_Object is record
@@ -86,7 +80,7 @@ private
       Waiting : Boolean;
       --  Flag showing if there is a task already suspended on this object
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for ensuring mutual exclusion on the Suspension_Object
 
       CV : aliased System.OS_Interface.pthread_cond_t;
@@ -110,7 +104,7 @@ private
       CV : aliased System.OS_Interface.pthread_cond_t;
       --  Should be commented ??? (in all versions of taspri)
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads
index 1fdfa8385b1..4d0b379556d 100644
--- a/gcc/ada/libgnarl/s-taspri__posix.ads
+++ b/gcc/ada/libgnarl/s-taspri__posix.ads
@@ -35,6 +35,7 @@
 --  Note: this file can only be used for POSIX compliant systems
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -42,11 +43,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the latter serves only as a semaphore so that
-   --  we do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -68,11 +64,9 @@ package System.Task_Primitives is
 
 private
 
-   type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
    type Lock is record
       RW : aliased System.OS_Interface.pthread_rwlock_t;
-      WO : aliased RTS_Lock;
+      WO : aliased System.OS_Locks.RTS_Lock;
    end record;
 
    type Suspension_Object is record
@@ -85,7 +79,7 @@ private
       Waiting : Boolean;
       --  Flag showing if there is a task already suspended on this object
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for ensuring mutual exclusion on the Suspension_Object
 
       CV : aliased System.OS_Interface.pthread_cond_t;
@@ -107,9 +101,9 @@ private
       --  On targets where lwp is not relevant, this is equivalent to Thread.
 
       CV : aliased System.OS_Interface.pthread_cond_t;
-      --  Should be commented ??? (in all versions of taspri)
+      --  Condition variable used to queue threads until condition is signaled
 
-      L : aliased RTS_Lock;
+      L : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads
index 33bd87ca221..ca40229993b 100644
--- a/gcc/ada/libgnarl/s-taspri__solaris.ads
+++ b/gcc/ada/libgnarl/s-taspri__solaris.ads
@@ -36,6 +36,7 @@
 with Ada.Unchecked_Conversion;
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -44,14 +45,8 @@ package System.Task_Primitives is
    type Lock_Ptr is access all Lock;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   type RTS_Lock_Ptr is access all RTS_Lock;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the later one serves only as a semaphore so
-   --  that do not check for ceiling violations.
-
    function To_Lock_Ptr is
-     new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+     new Ada.Unchecked_Conversion (OS_Locks.RTS_Lock_Ptr, Lock_Ptr);
 
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
@@ -74,31 +69,7 @@ package System.Task_Primitives is
 
 private
 
-   type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
-   --  Used to give each task a unique serial number
-
-   type Base_Lock is new System.OS_Interface.mutex_t;
-
-   type Owner_Int is new Integer;
-   for Owner_Int'Alignment use Standard'Maximum_Alignment;
-
-   type Owner_ID is access all Owner_Int;
-
-   function To_Owner_ID is
-     new Ada.Unchecked_Conversion (System.Address, Owner_ID);
-
-   type Lock is record
-      L              : aliased Base_Lock;
-      Ceiling        : System.Any_Priority := System.Any_Priority'First;
-      Saved_Priority : System.Any_Priority := System.Any_Priority'First;
-      Owner          : Owner_ID;
-      Next           : Lock_Ptr;
-      Level          : Private_Task_Serial_Number := 0;
-      Buddy          : Owner_ID;
-      Frozen         : Boolean := False;
-   end record;
-
-   type RTS_Lock is new Lock;
+   type Lock is new OS_Locks.RTS_Lock;
 
    type Suspension_Object is record
       State : Boolean;
@@ -133,7 +104,9 @@ private
       --  The LWP id of the thread. Set by self in Enter_Task
 
       CV : aliased System.OS_Interface.cond_t;
-      L  : aliased RTS_Lock;
+      --  Condition variable used to queue threads until condition is signaled
+
+      L  : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
 
       Active_Priority : System.Any_Priority := System.Any_Priority'First;
diff --git a/gcc/ada/libgnarl/s-taspri__vxworks.ads b/gcc/ada/libgnarl/s-taspri__vxworks.ads
index 9dc26c99d94..4c2aff8c46f 100644
--- a/gcc/ada/libgnarl/s-taspri__vxworks.ads
+++ b/gcc/ada/libgnarl/s-taspri__vxworks.ads
@@ -32,6 +32,7 @@
 --  This is a VxWorks version of this package
 
 with System.OS_Interface;
+with System.OS_Locks;
 
 package System.Task_Primitives is
    pragma Preelaborate;
@@ -39,11 +40,6 @@ package System.Task_Primitives is
    type Lock is limited private;
    --  Should be used for implementation of protected objects
 
-   type RTS_Lock is limited private;
-   --  Should be used inside the runtime system. The difference between Lock
-   --  and the RTS_Lock is that the later one serves only as a semaphore so
-   --  that do not check for ceiling violations.
-
    type Suspension_Object is limited private;
    --  Should be used for the implementation of Ada.Synchronous_Task_Control
 
@@ -65,17 +61,7 @@ package System.Task_Primitives is
 
 private
 
-   type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
-
-   type Lock is record
-      Mutex    : System.OS_Interface.SEM_ID;
-      Protocol : Priority_Type;
-
-      Prio_Ceiling : System.OS_Interface.int;
-      --  Priority ceiling of lock
-   end record;
-
-   type RTS_Lock is new Lock;
+   type Lock is new System.OS_Locks.RTS_Lock;
 
    type Suspension_Object is record
       State : Boolean;
@@ -109,8 +95,9 @@ private
       --  On targets where lwp is not relevant, this is equivalent to Thread.
 
       CV : aliased System.OS_Interface.SEM_ID;
+      --  Condition variable used to queue threads until condition is signaled
 
-      L  : aliased RTS_Lock;
+      L  : aliased System.OS_Locks.RTS_Lock;
       --  Protection for all components is lock L
    end record;
 
diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 89f5f2952e4..028c9d76062 100644
--- a/gcc/ada/libgnat/s-finpri.adb
+++ b/gcc/ada/libgnat/s-finpri.adb
@@ -32,8 +32,7 @@
 with Ada.Exceptions;           use Ada.Exceptions;
 with Ada.Unchecked_Conversion;
 
-with System.Atomic_Primitives; use System.Atomic_Primitives;
-with System.Soft_Links;        use System.Soft_Links;
+with System.Soft_Links; use System.Soft_Links;
 
 package body System.Finalization_Primitives is
 
@@ -402,7 +401,7 @@ package body System.Finalization_Primitives is
       Collection.Head.Prev := Collection.Head'Unchecked_Access;
       Collection.Head.Next := Collection.Head'Unchecked_Access;
 
-      Collection.Lock := 0;
+      Initialize_RTS_Lock (Collection.Lock'Address);
    end Initialize;
 
    ---------------------
@@ -411,9 +410,7 @@ package body System.Finalization_Primitives is
 
    procedure Lock_Collection (Collection : in out Finalization_Collection) is
    begin
-      while Atomic_Test_And_Set (Collection.Lock'Address, Acquire) loop
-         null;
-      end loop;
+      Acquire_RTS_Lock (Collection.Lock'Address);
    end Lock_Collection;
 
    -------------------------------------
@@ -430,10 +427,8 @@ package body System.Finalization_Primitives is
    -----------------------
 
    procedure Unlock_Collection (Collection : in out Finalization_Collection) is
-      procedure Lock_Store is new Atomic_Store (Lock_Type);
-
    begin
-      Lock_Store (Collection.Lock'Address, 0, Release);
+      Release_RTS_Lock (Collection.Lock'Address);
    end Unlock_Collection;
 
 end System.Finalization_Primitives;
diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads
index b0b662ca39c..62c2474b4f4 100644
--- a/gcc/ada/libgnat/s-finpri.ads
+++ b/gcc/ada/libgnat/s-finpri.ads
@@ -31,6 +31,7 @@
 
 with Ada.Finalization;
 
+with System.OS_Locks;
 with System.Storage_Elements;
 
 --  This package encapsulates the types and operations used by the compiler
@@ -251,9 +252,8 @@ private
       --  of a collection. The allocations must raise Program_Error. This may
       --  arise in a multitask environment.
 
-      Lock : Lock_Type;
-      pragma Atomic (Lock);
-      --  A spinlock to synchronize concurrent accesses to the collection
+      Lock : aliased System.OS_Locks.RTS_Lock;
+      --  A lock to synchronize concurrent accesses to the collection
    end record;
 
    --  This operation is very simple and thus can be performed in line
diff --git a/gcc/ada/libgnat/s-oslock__dummy.ads b/gcc/ada/libgnat/s-oslock__dummy.ads
new file mode 100644
index 00000000000..88e52e8ecaf
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__dummy.ads
@@ -0,0 +1,39 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a no tasking version of this package
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type RTS_Lock is new Boolean;
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-oslock__hpux-dce.ads b/gcc/ada/libgnat/s-oslock__hpux-dce.ads
new file mode 100644
index 00000000000..824c39511ea
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__hpux-dce.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the HP-UX version of this package
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type pthread_mutex_t is limited private;
+
+   subtype RTS_Lock is pthread_mutex_t;
+   --  Should be used inside the runtime system. The difference between Lock
+   --  and the RTS_Lock is that the latter serves only as a semaphore so that
+   --  we do not check for ceiling violations.
+
+private
+
+   type cma_t_address is new System.Address;
+
+   type cma_t_handle is record
+      field1 : cma_t_address;
+      field2 : Short_Integer;
+      field3 : Short_Integer;
+   end record;
+   for cma_t_handle'Size use 64;
+
+   type pthread_mutex_t is new cma_t_handle;
+   pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-oslock__mingw.ads b/gcc/ada/libgnat/s-oslock__mingw.ads
new file mode 100644
index 00000000000..e5fdb7fffff
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__mingw.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a NT (native) version of this package
+
+with Interfaces.C;
+with System.Win32;
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type CRITICAL_SECTION is limited private;
+
+   subtype RTS_Lock is CRITICAL_SECTION;
+   --  Should be used inside the runtime system. The difference between Lock
+   --  and the RTS_Lock is that the later one serves only as a semaphore so
+   --  that do not check for ceiling violations.
+
+private
+
+   type CRITICAL_SECTION is record
+      DebugInfo : System.Address;
+
+      LockCount      : Long_Integer;
+      RecursionCount : Long_Integer;
+      OwningThread   : Win32.HANDLE;
+      --  The above three fields control entering and exiting the critical
+      --  section for the resource.
+
+      LockSemaphore : Win32.HANDLE;
+      SpinCount     : Interfaces.C.size_t;
+   end record;
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-oslock__posix.ads b/gcc/ada/libgnat/s-oslock__posix.ads
new file mode 100644
index 00000000000..e2c237f2698
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__posix.ads
@@ -0,0 +1,57 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a POSIX-like version of this package
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type pthread_mutex_t is limited private;
+
+   subtype RTS_Lock is pthread_mutex_t;
+   --  Should be used inside the runtime system. The difference between Lock
+   --  and the RTS_Lock is that the latter serves only as a semaphore so that
+   --  we do not check for ceiling violations.
+
+private
+
+   subtype char_array is Interfaces.C.char_array;
+
+   type pthread_mutex_t is record
+      Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
+   end record;
+   pragma Convention (C, pthread_mutex_t);
+   for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-oslock__solaris.ads b/gcc/ada/libgnat/s-oslock__solaris.ads
new file mode 100644
index 00000000000..8cf7c694904
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__solaris.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a Solaris (native) version of this package
+
+with Interfaces.C;
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type mutex_t is limited private;
+
+   type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
+   --  Used to give each task a unique serial number
+
+   type Owner_Int is new Integer;
+   for Owner_Int'Alignment use Standard'Maximum_Alignment;
+
+   type Owner_ID is access all Owner_Int;
+
+   function To_Owner_ID is
+     new Ada.Unchecked_Conversion (System.Address, Owner_ID);
+
+   type RTS_Lock;
+   type RTS_Lock_Ptr is access all RTS_Lock;
+
+   type RTS_Lock is record
+      L              : aliased mutex_t;
+      Ceiling        : System.Any_Priority := System.Any_Priority'First;
+      Saved_Priority : System.Any_Priority := System.Any_Priority'First;
+      Owner          : Owner_ID;
+      Next           : RTS_Lock_Ptr;
+      Level          : Private_Task_Serial_Number := 0;
+      Buddy          : Owner_ID;
+      Frozen         : Boolean := False;
+   end record;
+
+private
+
+   type array_type_9 is array (0 .. 3) of unsigned_char;
+   type record_type_3 is record
+      flag  : array_type_9;
+      Xtype : unsigned_long;
+   end record;
+   pragma Convention (C, record_type_3);
+
+   type upad64_t is new Interfaces.Unsigned_64;
+
+   type mutex_t is record
+      flags : record_type_3;
+      lock  : upad64_t;
+      data  : upad64_t;
+   end record;
+  pragma Convention (C, mutex_t);
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-oslock__vxworks.ads b/gcc/ada/libgnat/s-oslock__vxworks.ads
new file mode 100644
index 00000000000..c819d1afdf6
--- /dev/null
+++ b/gcc/ada/libgnat/s-oslock__vxworks.ads
@@ -0,0 +1,48 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                       S Y S T E M . O S _ L O C K S                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2024, Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a VxWorks version of this package
+
+with Interfaces.C;
+with System.VxWorks.Ext;
+
+package System.OS_Locks is
+   pragma Preelaborate;
+
+   type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
+
+   type RTS_Lock is record
+      Mutex        : System.VxWorks.Ext.SEM_ID;
+      Protocol     : Priority_Type;
+      Prio_Ceiling : Interfaces.C.int;
+   end record;
+
+end System.OS_Locks;
diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads
index 5cf5a8b43e7..e88268081d8 100644
--- a/gcc/ada/libgnat/s-soflin.ads
+++ b/gcc/ada/libgnat/s-soflin.ads
@@ -251,6 +251,20 @@ package System.Soft_Links is
 
    Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
 
+   ----------------------
+   -- Locking Soft-Links --
+   ----------------------
+
+   procedure Null_Set_Address (Addr : Address) is null;
+
+   --  Soft-Links are used for procedures that manipulate locks to avoid
+   --  dragging the tasking run time when using access-to-controlled types.
+
+   Initialize_RTS_Lock : Set_Address_Call := Null_Set_Address'Access;
+   Finalize_RTS_Lock   : Set_Address_Call := Null_Set_Address'Access;
+   Acquire_RTS_Lock    : Set_Address_Call := Null_Set_Address'Access;
+   Release_RTS_Lock    : Set_Address_Call := Null_Set_Address'Access;
+
    --------------------------
    -- Master_Id Soft-Links --
    --------------------------
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 5f402cf5d6e..e56a40884e4 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1919,6 +1919,10 @@ package Opt is
    --  be in the spec of Expander, but it is referenced by Errout, and it
    --  really seems wrong for Errout to depend on Expander.
 
+   Interface_Seen : Boolean := False;
+   --  Set True by the parser if the "interface" reserved word is seen. This is
+   --  needed in Exp_Ch7 (see that package for documentation).
+
    Tagged_Seen : Boolean := False;
    --  Set True by the parser if the "tagged" reserved word is seen. This is
    --  needed in Exp_Put_Image (see that package for documentation).
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index 4e512b96031..946da3466f0 100644
--- a/gcc/ada/s-oscons-tmplt.c
+++ b/gcc/ada/s-oscons-tmplt.c
@@ -30,8 +30,8 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-pragma Style_Checks ("M32766");
---  Allow long lines
+pragma Style_Checks ("N");
+--  Disable style checks
 
 */
 
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index 0a9c4a8e20c..9b1d00e3452 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -2725,9 +2725,12 @@ package body Scng is
             Accumulate_Token_Checksum;
             Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
 
+            if Token = Tok_Interface then
+               Interface_Seen := True;
+
             --  See Exp_Put_Image for documentation of Tagged_Seen
 
-            if Token = Tok_Tagged then
+            elsif Token = Tok_Tagged then
                Tagged_Seen := True;
             end if;
 
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 73e5388affd..82b4e1cf3f5 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -31,6 +31,7 @@ with Einfo;          use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
 with Errout;         use Errout;
+with Exp_Ch7;
 with Exp_Disp;       use Exp_Disp;
 with Exp_Put_Image;
 with Exp_Util;       use Exp_Util;
@@ -925,6 +926,8 @@ package body Sem_Ch10 is
 
       Set_Context_Pending (N, False);
 
+      Exp_Ch7.Preload_Finalization_Collection (N);
+
       --  If the unit is a package body, the spec is already loaded and must be
       --  analyzed first, before we analyze the body.
 
-- 
2.43.2

[COMMITTED 30/35] ada: Further adjustments coming from aliasing considerations

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

They are needed on 32-bit platforms because of different calling conventions
and again in the units implementing AltiVec and Streams support.

gcc/ada/

	* libgnat/g-alvevi.ads: Add pragma Universal_Aliasing for all the
	view types.
	* libgnat/s-stratt.ads: Likewise for Fat_Pointer type.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/libgnat/g-alvevi.ads | 11 +++++++++++
 gcc/ada/libgnat/s-stratt.ads |  3 +++
 2 files changed, 14 insertions(+)

diff --git a/gcc/ada/libgnat/g-alvevi.ads b/gcc/ada/libgnat/g-alvevi.ads
index b2beac7284c..b0f58790adf 100644
--- a/gcc/ada/libgnat/g-alvevi.ads
+++ b/gcc/ada/libgnat/g-alvevi.ads
@@ -58,6 +58,7 @@ package GNAT.Altivec.Vector_Views is
    type VUC_View is record
       Values : Varray_unsigned_char;
    end record;
+   pragma Universal_Aliasing (VUC_View);
 
    type Varray_signed_char is array (Vchar_Range) of signed_char;
    for Varray_signed_char'Alignment use VECTOR_ALIGNMENT;
@@ -65,6 +66,7 @@ package GNAT.Altivec.Vector_Views is
    type VSC_View is record
       Values : Varray_signed_char;
    end record;
+   pragma Universal_Aliasing (VSC_View);
 
    type Varray_bool_char is array (Vchar_Range) of bool_char;
    for Varray_bool_char'Alignment use VECTOR_ALIGNMENT;
@@ -72,6 +74,7 @@ package GNAT.Altivec.Vector_Views is
    type VBC_View is record
       Values : Varray_bool_char;
    end record;
+   pragma Universal_Aliasing (VBC_View);
 
    ----------------------
    -- short components --
@@ -85,6 +88,7 @@ package GNAT.Altivec.Vector_Views is
    type VUS_View is record
       Values : Varray_unsigned_short;
    end record;
+   pragma Universal_Aliasing (VUS_View);
 
    type Varray_signed_short is array (Vshort_Range) of signed_short;
    for Varray_signed_short'Alignment use VECTOR_ALIGNMENT;
@@ -92,6 +96,7 @@ package GNAT.Altivec.Vector_Views is
    type VSS_View is record
       Values : Varray_signed_short;
    end record;
+   pragma Universal_Aliasing (VSS_View);
 
    type Varray_bool_short is array (Vshort_Range) of bool_short;
    for Varray_bool_short'Alignment use VECTOR_ALIGNMENT;
@@ -99,6 +104,7 @@ package GNAT.Altivec.Vector_Views is
    type VBS_View is record
       Values : Varray_bool_short;
    end record;
+   pragma Universal_Aliasing (VBS_View);
 
    --------------------
    -- int components --
@@ -112,6 +118,7 @@ package GNAT.Altivec.Vector_Views is
    type VUI_View is record
       Values : Varray_unsigned_int;
    end record;
+   pragma Universal_Aliasing (VUI_View);
 
    type Varray_signed_int is array (Vint_Range) of signed_int;
    for Varray_signed_int'Alignment use VECTOR_ALIGNMENT;
@@ -119,6 +126,7 @@ package GNAT.Altivec.Vector_Views is
    type VSI_View is record
       Values : Varray_signed_int;
    end record;
+   pragma Universal_Aliasing (VSI_View);
 
    type Varray_bool_int is array (Vint_Range) of bool_int;
    for Varray_bool_int'Alignment use VECTOR_ALIGNMENT;
@@ -126,6 +134,7 @@ package GNAT.Altivec.Vector_Views is
    type VBI_View is record
       Values : Varray_bool_int;
    end record;
+   pragma Universal_Aliasing (VBI_View);
 
    ----------------------
    -- float components --
@@ -139,6 +148,7 @@ package GNAT.Altivec.Vector_Views is
    type VF_View is record
       Values : Varray_float;
    end record;
+   pragma Universal_Aliasing (VF_View);
 
    ----------------------
    -- pixel components --
@@ -152,5 +162,6 @@ package GNAT.Altivec.Vector_Views is
    type VP_View is record
       Values : Varray_pixel;
    end record;
+   pragma Universal_Aliasing (VP_View);
 
 end GNAT.Altivec.Vector_Views;
diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads
index 1d4c82d17ab..eee19f4bdce 100644
--- a/gcc/ada/libgnat/s-stratt.ads
+++ b/gcc/ada/libgnat/s-stratt.ads
@@ -74,6 +74,9 @@ package System.Stream_Attributes is
       P2 : System.Address;
    end record;
 
+   pragma Universal_Aliasing (Fat_Pointer);
+   --  This avoids a copy for the aforementioned unchecked conversions
+
    ------------------------------------
    -- Treatment of enumeration types --
    ------------------------------------
-- 
2.43.2

[COMMITTED 31/35] ada: Restore dependency on System.OS_Interface in System.Task_Primitives

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The dependency is relied upon by the binder to drag the tasking runtime.

gcc/ada/

	* libgnarl/s-taspri__mingw.ads: Add clause for System.OS_Interface.
	(Private_Data): Change type of Thread component.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/libgnarl/s-taspri__mingw.ads | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads
index a51f752d805..6eae97d4af6 100644
--- a/gcc/ada/libgnarl/s-taspri__mingw.ads
+++ b/gcc/ada/libgnarl/s-taspri__mingw.ads
@@ -31,6 +31,7 @@
 
 --  This is a NT (native) version of this package
 
+with System.OS_Interface;
 with System.OS_Locks;
 with System.Win32;
 
@@ -87,7 +88,7 @@ private
    end record;
 
    type Private_Data is limited record
-      Thread : aliased Win32.HANDLE;
+      Thread : aliased System.OS_Interface.Thread_Id;
       pragma Atomic (Thread);
       --  Thread field may be updated by two different threads of control.
       --  (See, Enter_Task and Create_Task in s-taprop.adb).
-- 
2.43.2

[COMMITTED 32/35] ada: Improve test for unprocessed preprocessor directives

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

Preprocessor directives are case insensitive and may have spaces or tabs
between the '#' and the keyword. When checking for the error case of
unprocessed preprocessor directives, take these rules into account.

gcc/ada/

	* scng.adb (scan): When checking for an unprocessed preprocessor
	directive, take into account the preprocessor's rules about case
	insensitivity and about white space between the '#' and the
	keyword.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/scng.adb | 183 +++++++++++++++++++++++++++++++----------------
 1 file changed, 122 insertions(+), 61 deletions(-)

diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index 9b1d00e3452..8b2829ffbbf 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -40,6 +40,7 @@ with Widechar; use Widechar;
 
 pragma Warnings (Off);
 --  This package is used also by gnatcoll
+with System.Case_Util;
 with System.CRC32;
 with System.UTF_32;  use System.UTF_32;
 with System.WCh_Con; use System.WCh_Con;
@@ -2250,86 +2251,146 @@ package body Scng is
 
          when Special_Preprocessor_Character =>
 
-            --  If Set_Special_Character has been called for this character,
-            --  set Scans.Special_Character and return a Special token.
+            declare
+               function Matches_After_Skipping_White_Space
+                 (S : String) return Boolean;
+
+               --  Return True iff after skipping past white space the
+               --  next Source characters match the given string.
+
+               ----------------------------------------
+               -- Matches_After_Skipping_White_Space --
+               ----------------------------------------
+
+               function Matches_After_Skipping_White_Space
+                 (S : String) return Boolean
+               is
+                  function To_Lower_Case_String (Buff : Text_Buffer)
+                    return String;
+                  --  Convert a text buffer to a lower-case string.
+
+                  --------------------------
+                  -- To_Lower_Case_String --
+                  --------------------------
+
+                  function To_Lower_Case_String (Buff : Text_Buffer)
+                    return String
+                  is
+                     subtype One_Based is Text_Buffer (1 .. Buff'Length);
+                     Result : String := String (One_Based (Buff));
+                  begin
+                     --  The System.Case_Util.To_Lower function (the overload
+                     --  that takes a string parameter) cannot be called
+                     --  here due to bootstrapping problems. That function
+                     --  was added too recently.
+
+                     System.Case_Util.To_Lower (Result);
+                     return Result;
+                  end To_Lower_Case_String;
+
+                  pragma Assert (Source (Scan_Ptr) = '#');
+                  Local_Scan_Ptr : Source_Ptr := Scan_Ptr + 1;
+
+               --  Start of processing for Matches_After_Skipping_White_Space
 
-            if Special_Characters (Source (Scan_Ptr)) then
-               Token_Ptr := Scan_Ptr;
-               Token := Tok_Special;
-               Special_Character := Source (Scan_Ptr);
-               Scan_Ptr := Scan_Ptr + 1;
-               return;
+               begin
+                  while Local_Scan_Ptr in Source'Range
+                    and then Source (Local_Scan_Ptr) in ' ' | HT
+                  loop
+                     Local_Scan_Ptr := Local_Scan_Ptr + 1;
+                  end loop;
 
-            --  Check for something looking like a preprocessor directive
+                  return Local_Scan_Ptr in Source'Range
+                    and then Local_Scan_Ptr + (S'Length - 1) in Source'Range
+                    and then S = To_Lower_Case_String (
+                                   Source (Local_Scan_Ptr ..
+                                           Local_Scan_Ptr + (S'Length - 1)));
+               end Matches_After_Skipping_White_Space;
 
-            elsif Source (Scan_Ptr) = '#'
-              and then (Source (Scan_Ptr + 1 .. Scan_Ptr + 2) = "if"
-                          or else
-                        Source (Scan_Ptr + 1 .. Scan_Ptr + 5) = "elsif"
-                          or else
-                        Source (Scan_Ptr + 1 .. Scan_Ptr + 4) = "else"
-                          or else
-                        Source (Scan_Ptr + 1 .. Scan_Ptr + 3) = "end")
-            then
-               Error_Msg_S
-                 ("preprocessor directive ignored, preprocessor not active");
+            begin
+               --  If Set_Special_Character has been called for this character,
+               --  set Scans.Special_Character and return a Special token.
 
-               --  Skip to end of line
+               if Special_Characters (Source (Scan_Ptr)) then
+                  Token_Ptr := Scan_Ptr;
+                  Token := Tok_Special;
+                  Special_Character := Source (Scan_Ptr);
+                  Scan_Ptr := Scan_Ptr + 1;
+                  return;
 
-               loop
-                  if Source (Scan_Ptr) in Graphic_Character
-                       or else
-                     Source (Scan_Ptr) = HT
-                  then
-                     Scan_Ptr := Scan_Ptr + 1;
+               --  Check for something looking like a preprocessor directive
+
+               elsif Source (Scan_Ptr) = '#'
+                 and then (Matches_After_Skipping_White_Space ("if")
+                             or else
+                           Matches_After_Skipping_White_Space ("elsif")
+                             or else
+                           Matches_After_Skipping_White_Space ("else")
+                             or else
+                           Matches_After_Skipping_White_Space ("end"))
+               then
+                  Error_Msg_S
+                    ("preprocessor directive ignored" &
+                     ", preprocessor not active");
 
-                  --  Done if line terminator or EOF
+                  --  Skip to end of line
 
-                  elsif Source (Scan_Ptr) in Line_Terminator
+                  loop
+                     if Source (Scan_Ptr) in Graphic_Character
                           or else
-                        Source (Scan_Ptr) = EOF
-                  then
-                     exit;
+                        Source (Scan_Ptr) = HT
+                     then
+                        Scan_Ptr := Scan_Ptr + 1;
 
-                  --  If we have a wide character, we have to scan it out,
-                  --  because it might be a legitimate line terminator
+                     --  Done if line terminator or EOF
 
-                  elsif Start_Of_Wide_Character then
-                     declare
-                        Wptr : constant Source_Ptr := Scan_Ptr;
-                        Code : Char_Code;
-                        Err  : Boolean;
+                     elsif Source (Scan_Ptr) in Line_Terminator
+                             or else
+                           Source (Scan_Ptr) = EOF
+                     then
+                        exit;
 
-                     begin
-                        Scan_Wide (Source, Scan_Ptr, Code, Err);
+                     --  If we have a wide character, we have to scan it out,
+                     --  because it might be a legitimate line terminator
 
-                        --  If not well formed wide character, then just skip
-                        --  past it and ignore it.
+                     elsif Start_Of_Wide_Character then
+                        declare
+                           Wptr : constant Source_Ptr := Scan_Ptr;
+                           Code : Char_Code;
+                           Err  : Boolean;
 
-                        if Err then
-                           Scan_Ptr := Wptr + 1;
+                        begin
+                           Scan_Wide (Source, Scan_Ptr, Code, Err);
 
-                        --  If UTF_32 terminator, terminate comment scan
+                           --  If not well formed wide character, then just
+                           --  skip past it and ignore it.
 
-                        elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
-                           Scan_Ptr := Wptr;
-                           exit;
-                        end if;
-                     end;
+                           if Err then
+                              Scan_Ptr := Wptr + 1;
 
-                  --  Else keep going (don't worry about bad comment chars
-                  --  in this context, we just want to find the end of line.
+                           --  If UTF_32 terminator, terminate comment scan
 
-                  else
-                     Scan_Ptr := Scan_Ptr + 1;
-                  end if;
-               end loop;
+                           elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
+                              Scan_Ptr := Wptr;
+                              exit;
+                           end if;
+                        end;
 
-            --  Otherwise, this is an illegal character
+                     --  Else keep going (don't worry about bad comment chars
+                     --  in this context, we just want to find the end of line.
 
-            else
-               Error_Illegal_Character;
-            end if;
+                     else
+                        Scan_Ptr := Scan_Ptr + 1;
+                     end if;
+                  end loop;
+
+               --  Otherwise, this is an illegal character
+
+               else
+                  Error_Illegal_Character;
+               end if;
+
+            end;
 
          --  End switch on non-blank character
 
-- 
2.43.2

[COMMITTED 33/35] ada: Start the initialization of the tasking runtime earlier

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

This installs the tasking versions of the RTS_Lock manipulation routines
very early, before the elaboration of all the Ada units of the program,
including those of the runtime, because this elaboration may require the
initialization of RTS_Lock objects.

gcc/ada/

	* bindgen.adb (Gen_Adainit): Generate declaration and call to the
	imported procedure __gnat_tasking_runtime_initialize if need be.
	* libgnat/s-soflin.ads (Locking Soft-Links): Add commentary.
	* libgnarl/s-tasini.adb (Tasking_Runtime_Initialize): New procedure
	exported as __gnat_tasking_runtime_initialize.  Initialize RTS_Lock
	manipulation routines here instead of...
	(Init_RTS): ...here.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/bindgen.adb           | 18 ++++++++++++++++--
 gcc/ada/libgnarl/s-tasini.adb | 30 +++++++++++++++++++++---------
 gcc/ada/libgnat/s-soflin.ads  |  4 +++-
 3 files changed, 40 insertions(+), 12 deletions(-)

diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index fc834e3a9b6..f15f96495df 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -819,8 +819,7 @@ package body Bindgen is
             WBI ("      pragma Import (C, XDR_Stream, ""__gl_xdr_stream"");");
          end if;
 
-         --  Import entry point for elaboration time signal handler
-         --  installation, and indication of if it's been called previously.
+         --  Import entry point for initialization of the runtime
 
          WBI ("");
          WBI ("      procedure Runtime_Initialize " &
@@ -828,6 +827,15 @@ package body Bindgen is
          WBI ("      pragma Import (C, Runtime_Initialize, " &
               """__gnat_runtime_initialize"");");
 
+         --  Import entry point for initialization of the tasking runtime
+
+         if With_GNARL then
+            WBI ("");
+            WBI ("      procedure Tasking_Runtime_Initialize;");
+            WBI ("      pragma Import (C, Tasking_Runtime_Initialize, " &
+                 """__gnat_tasking_runtime_initialize"");");
+         end if;
+
          --  Import handlers attach procedure for sequential elaboration policy
 
          if System_Interrupts_Used
@@ -1090,6 +1098,12 @@ package body Bindgen is
          --  Generate call to Runtime_Initialize
 
          WBI ("      Runtime_Initialize (1);");
+
+         --  Generate call to Tasking_Runtime_Initialize
+
+         if With_GNARL then
+            WBI ("      Tasking_Runtime_Initialize;");
+         end if;
       end if;
 
       --  Generate call to set Initialize_Scalar values if active
diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb
index 22294145bed..794183f5356 100644
--- a/gcc/ada/libgnarl/s-tasini.adb
+++ b/gcc/ada/libgnarl/s-tasini.adb
@@ -102,10 +102,6 @@ package body System.Tasking.Initialization is
    procedure Release_RTS_Lock (Addr : Address);
    --  Release the RTS lock at Addr
 
-   ------------------------
-   --  Local Subprograms --
-   ------------------------
-
    ----------------------------
    -- Tasking Initialization --
    ----------------------------
@@ -116,6 +112,15 @@ package body System.Tasking.Initialization is
    --  of initializing global locks, and installing tasking versions of certain
    --  operations used by the compiler. Init_RTS is called during elaboration.
 
+   procedure Tasking_Runtime_Initialize;
+   pragma Export (Ada, Tasking_Runtime_Initialize,
+                  "__gnat_tasking_runtime_initialize");
+   --  This procedure starts the initialization of the GNARL. It installs the
+   --  tasking versions of the RTS_Lock manipulation routines. It is called
+   --  very early before the elaboration of all the Ada units of the program,
+   --  including those of the runtime, because this elaboration may require
+   --  the initialization of RTS_Lock objects.
+
    --------------------------
    -- Change_Base_Priority --
    --------------------------
@@ -414,11 +419,6 @@ package body System.Tasking.Initialization is
       SSL.Task_Name          := Task_Name'Access;
       SSL.Get_Current_Excep  := Get_Current_Excep'Access;
 
-      SSL.Initialize_RTS_Lock := Initialize_RTS_Lock'Access;
-      SSL.Finalize_RTS_Lock   := Finalize_RTS_Lock'Access;
-      SSL.Acquire_RTS_Lock    := Acquire_RTS_Lock'Access;
-      SSL.Release_RTS_Lock    := Release_RTS_Lock'Access;
-
       --  Initialize the tasking soft links (if not done yet) that are common
       --  to the full and the restricted run times.
 
@@ -430,6 +430,18 @@ package body System.Tasking.Initialization is
       Undefer_Abort (Environment_Task);
    end Init_RTS;
 
+   --------------------------------
+   -- Tasking_Runtime_Initialize --
+   --------------------------------
+
+   procedure Tasking_Runtime_Initialize is
+   begin
+      SSL.Initialize_RTS_Lock := Initialize_RTS_Lock'Access;
+      SSL.Finalize_RTS_Lock   := Finalize_RTS_Lock'Access;
+      SSL.Acquire_RTS_Lock    := Acquire_RTS_Lock'Access;
+      SSL.Release_RTS_Lock    := Release_RTS_Lock'Access;
+   end Tasking_Runtime_Initialize;
+
    ---------------------------
    -- Locked_Abort_To_Level--
    ---------------------------
diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads
index e88268081d8..c2d947535d9 100644
--- a/gcc/ada/libgnat/s-soflin.ads
+++ b/gcc/ada/libgnat/s-soflin.ads
@@ -258,12 +258,14 @@ package System.Soft_Links is
    procedure Null_Set_Address (Addr : Address) is null;
 
    --  Soft-Links are used for procedures that manipulate locks to avoid
-   --  dragging the tasking run time when using access-to-controlled types.
+   --  dragging the tasking runtime when using access-to-controlled types.
 
    Initialize_RTS_Lock : Set_Address_Call := Null_Set_Address'Access;
    Finalize_RTS_Lock   : Set_Address_Call := Null_Set_Address'Access;
    Acquire_RTS_Lock    : Set_Address_Call := Null_Set_Address'Access;
    Release_RTS_Lock    : Set_Address_Call := Null_Set_Address'Access;
+   --  The initialization of these variables must be static because the value
+   --  needs to be overridden very early when the tasking runtime is dragged.
 
    --------------------------
    -- Master_Id Soft-Links --
-- 
2.43.2

[COMMITTED 34/35] ada: Remove outdated workaround in aggregate expansion

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

Before this patch, the compiler refrained from rewriting aggregates
into purely positional form in some cases of one-component aggregates.
As explained in comments, this was because the back end could not
handle positional aggregates in those situations.

As the back end seems to have grown more capable, this patch removes
the workaround. It also extends the comments describing a warning that
is emitted in the same configuration with aggregates.

gcc/ada/

	* exp_aggr.adb (Aggr_Size_OK): Remove workaround and extend
	comment.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_aggr.adb | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 9c5944a917d..892f47ceb05 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -711,9 +711,10 @@ package body Exp_Aggr is
             return True;
          end if;
 
-         --  One-component aggregates are suspicious, and if the context type
-         --  is an object declaration with nonstatic bounds it will trip gcc;
-         --  such an aggregate must be expanded into a single assignment.
+         --  One-component named aggregates where the index constraint is not
+         --  known at compile time are suspicious as the user might have
+         --  intended to write a subtype name but wrote the name of an object
+         --  instead. We emit a warning if we're in such a case.
 
          if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then
             declare
@@ -741,8 +742,6 @@ package body Exp_Aggr is
                         Error_Msg_N ("\maybe subtype name was meant??", Indx);
                      end if;
                   end if;
-
-                  return False;
                end if;
             end;
          end if;
-- 
2.43.2

[COMMITTED 35/35] ada: Improve deriving initial sizes for container aggregates

[Marc Poulhiès]

From: Viljar Indus <indus@adacore.com>

Deriving the initial size of container aggregates is necessary
for deriving the correct capacity for bounded containers.

Add support for deriving the correct initial size
when the container aggregate is iterating over an array
object.

gcc/ada/

	* exp_aggr.adb (Expand_Container_Aggregate):
	Derive the size for iterable aggregates in the case of
	one-dimensional array objects.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_aggr.adb | 83 +++++++++++++++++++++++++++++---------------
 1 file changed, 55 insertions(+), 28 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 892f47ceb05..2476675604c 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6693,9 +6693,9 @@ package body Exp_Aggr is
 
             --  If one or more of the associations is one of the iterated
             --  forms, and is either an association with nonstatic bounds
-            --  or is an iterator over an iterable object, then treat the
-            --  whole container aggregate as having a nonstatic number of
-            --  elements.
+            --  or is an iterator over an iterable object where the size
+            --  cannot be derived, then treat the whole container aggregate as
+            --  having a nonstatic number of elements.
 
             declare
                Has_Nonstatic_Length : Boolean := False;
@@ -6725,37 +6725,43 @@ package body Exp_Aggr is
             Comp := First (Component_Associations (N));
 
             while Present (Comp) loop
-               Choice := First (Choice_List (Comp));
+               if Present (Choice_List (Comp)) then
+                  Choice := First (Choice_List (Comp));
 
-               while Present (Choice) loop
-                  Analyze (Choice);
+                  while Present (Choice) loop
+                     Analyze (Choice);
 
-                  if Nkind (Choice) = N_Range then
-                     Lo := Low_Bound (Choice);
-                     Hi := High_Bound (Choice);
-                     Add_Range_Size;
+                     if Nkind (Choice) = N_Range then
+                        Lo := Low_Bound (Choice);
+                        Hi := High_Bound (Choice);
+                        Add_Range_Size;
 
-                  elsif Is_Entity_Name (Choice)
-                    and then Is_Type (Entity (Choice))
-                  then
-                     Lo := Type_Low_Bound (Entity (Choice));
-                     Hi := Type_High_Bound (Entity (Choice));
-                     Add_Range_Size;
+                     elsif Is_Entity_Name (Choice)
+                       and then Is_Type (Entity (Choice))
+                     then
+                        Lo := Type_Low_Bound (Entity (Choice));
+                        Hi := Type_High_Bound (Entity (Choice));
+                        Add_Range_Size;
 
-                     Rewrite (Choice,
-                       Make_Range (Loc,
-                         New_Copy_Tree (Lo),
-                         New_Copy_Tree (Hi)));
+                        Rewrite (Choice,
+                          Make_Range (Loc,
+                            New_Copy_Tree (Lo),
+                            New_Copy_Tree (Hi)));
 
-                  else
-                     --  Single choice (syntax excludes a subtype
-                     --  indication).
+                     else
+                        --  Single choice (syntax excludes a subtype
+                        --  indication).
 
-                     Siz := Siz + 1;
-                  end if;
+                        Siz := Siz + 1;
+                     end if;
 
-                  Next (Choice);
-               end loop;
+                     Next (Choice);
+                  end loop;
+
+               elsif Nkind (Comp) = N_Iterated_Component_Association then
+
+                  Siz := Siz + Build_Siz_Exp (Comp);
+               end if;
                Next (Comp);
             end loop;
          end if;
@@ -6770,6 +6776,7 @@ package body Exp_Aggr is
       function Build_Siz_Exp (Comp : Node_Id) return Int is
          Lo, Hi       : Node_Id;
          Temp_Siz_Exp : Node_Id;
+         It           : Node_Id;
 
       begin
          if Nkind (Comp) = N_Range then
@@ -6835,8 +6842,28 @@ package body Exp_Aggr is
             end if;
 
          elsif Nkind (Comp) = N_Iterated_Component_Association then
-            return Build_Siz_Exp (First (Discrete_Choices (Comp)));
+            if Present (Iterator_Specification (Comp)) then
+
+               --  If the static size of the iterable object is known,
+               --  attempt to return it.
+
+               It := Name (Iterator_Specification (Comp));
+               Preanalyze (It);
 
+               --  Handle the simplest cases for now where It denotes a
+               --  top-level one-dimensional array objects".
+
+               if Nkind (It) in N_Identifier
+                 and then Ekind (Etype (It)) = E_Array_Subtype
+                 and then No (Next_Index (First_Index (Etype (It))))
+               then
+                  return Build_Siz_Exp (First_Index (Etype (It)));
+               end if;
+
+               return -1;
+            else
+               return Build_Siz_Exp (First (Discrete_Choices (Comp)));
+            end if;
          elsif Nkind (Comp) = N_Iterated_Element_Association then
             return -1;
 
-- 
2.43.2