[COMMITTED 01/13] ada: Document that -gnatdJ is unused

[COMMITTED 01/13] ada: Document that -gnatdJ is unused

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

gcc/ada/

	* debug.adb (dJ): Add back as unused.

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

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

diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index f7fcd399769..3313c4a408f 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -67,6 +67,7 @@ package body Debug is
    --  dG   Generate all warnings including those normally suppressed
    --  dH   Hold (kill) call to gigi
    --  dI   Inhibit internal name numbering in gnatG listing
+   --  dJ
    --  dK   Kill all error messages
    --  dL   Ignore external calls from instances for elaboration
    --  dM   Assume all variables are modified (no current values)
-- 
2.45.2

[COMMITTED 02/13] ada: Fix crash on box-initialized component with No_Default_Initialization

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The problem is that the implementation of the No_Default_Initialization
restriction assumes that no type initialization routines are needed and,
therefore, builds a dummy version of them, which goes against their use
for box-initialized components in aggregates.

Therefore this use needs to be flagged as violating the restriction too.

gcc/ada/

	* doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
	(No_Default_Initialization): Mention components alongside variables.
	* exp_aggr.adb (Build_Array_Aggr_Code.Gen_Assign): Check that the
	restriction No_Default_Initialization is not in effect for default
	initialized component.
	(Build_Record_Aggr_Code): Likewise.
	* gnat_rm.texi: Regenerate.

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

---
 ...nd_implementation_defined_restrictions.rst |  4 +-
 gcc/ada/exp_aggr.adb                          | 41 +++++++++++--------
 gcc/ada/gnat_rm.texi                          |  6 +--
 3 files changed, 29 insertions(+), 22 deletions(-)

diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
index cf4657b7050..0e9162a1906 100644
--- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
+++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
@@ -163,8 +163,8 @@ No_Default_Initialization
 .. index:: No_Default_Initialization
 
 [GNAT] This restriction prohibits any instance of default initialization
-of variables.  The binder implements a consistency rule which prevents
-any unit compiled without the restriction from with'ing a unit with the
+of variables or components. The binder implements a consistency check that
+prevents any unit without the restriction from with'ing a unit with the
 restriction (this allows the generation of initialization procedures to
 be skipped, since you can be sure that no call is ever generated to an
 initialization procedure in a unit with the restriction active). If used
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 01ad1dcd437..df228713a28 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1486,14 +1486,16 @@ package body Exp_Aggr is
          --  object creation that will invoke it otherwise.
 
          else
-            if Present (Base_Init_Proc (Base_Type (Ctype)))
-              or else Has_Task (Base_Type (Ctype))
-            then
-               Append_List_To (Stmts,
-                 Build_Initialization_Call (N,
-                   Id_Ref            => Indexed_Comp,
-                   Typ               => Ctype,
-                   With_Default_Init => True));
+            if Present (Base_Init_Proc (Ctype)) then
+               Check_Restriction (No_Default_Initialization, N);
+
+               if not Restriction_Active (No_Default_Initialization) then
+                  Append_List_To (Stmts,
+                    Build_Initialization_Call (N,
+                      Id_Ref            => Indexed_Comp,
+                      Typ               => Ctype,
+                      With_Default_Init => True));
+               end if;
 
                --  If the component type has invariants, add an invariant
                --  check after the component is default-initialized. It will
@@ -3185,6 +3187,8 @@ package body Exp_Aggr is
          elsif Box_Present (Comp)
            and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
          then
+            Check_Restriction (No_Default_Initialization, N);
+
             if Ekind (Selector) /= E_Discriminant then
                Generate_Finalization_Actions;
             end if;
@@ -3216,15 +3220,18 @@ package body Exp_Aggr is
                end if;
             end;
 
-            Append_List_To (L,
-              Build_Initialization_Call (N,
-                Id_Ref            => Make_Selected_Component (Loc,
-                                       Prefix        => New_Copy_Tree (Target),
-                                       Selector_Name =>
-                                         New_Occurrence_Of (Selector, Loc)),
-                Typ               => Etype (Selector),
-                Enclos_Type       => Typ,
-                With_Default_Init => True));
+            if not Restriction_Active (No_Default_Initialization) then
+               Append_List_To (L,
+                 Build_Initialization_Call (N,
+                   Id_Ref            => Make_Selected_Component (Loc,
+                                          Prefix        =>
+                                            New_Copy_Tree (Target),
+                                          Selector_Name =>
+                                            New_Occurrence_Of (Selector, Loc)),
+                   Typ               => Etype (Selector),
+                   Enclos_Type       => Typ,
+                   With_Default_Init => True));
+            end if;
 
          --  Prepare for component assignment
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index dc5721689cb..4feef7e1f9f 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , Jun 24, 2024
+GNAT Reference Manual , Jun 27, 2024
 
 AdaCore
 
@@ -12594,8 +12594,8 @@ coextensions. See 3.10.2.
 @geindex No_Default_Initialization
 
 [GNAT] This restriction prohibits any instance of default initialization
-of variables.  The binder implements a consistency rule which prevents
-any unit compiled without the restriction from with’ing a unit with the
+of variables or components. The binder implements a consistency check that
+prevents any unit without the restriction from with’ing a unit with the
 restriction (this allows the generation of initialization procedures to
 be skipped, since you can be sure that no call is ever generated to an
 initialization procedure in a unit with the restriction active). If used
-- 
2.45.2

[COMMITTED 03/13] ada: Miscomputed bounds for inner null array aggregates

[Marc Poulhiès]

From: Javier Miranda <miranda@adacore.com>

When an array has several dimensions, and inner dimmensions are
initialized using Ada 2022 null array aggregates, the compiler
crashes or reports spurious errors computing the bounds of the
null array aggregates. This patch fixes the problem and adds
new warnings reported when the index of null array aggregates is
an enumeration type or a modular type and it is known at compile
time that the program will raise Constraint_Error computing the
bounds of the aggregate.

gcc/ada/

	* sem_aggr.adb (Cannot_Compute_High_Bound): New subprogram.
	(Report_Null_Array_Constraint_Error): New subprogram.
	(Collect_Aggr_Bounds): For null aggregates, build the bounds
	of the inner dimensions.
	(Has_Null_Aggregate_Raising_Constraint_Error): New subprogram.
	(Subtract): New subprogram.
	(Resolve_Array_Aggregate): Report a warning when the index of
	null array aggregates is an enumeration type or a modular type
	at we can statically determine that the program will raise CE
	at runtime computing its high bound.
	(Resolve_Null_Array_Aggregate): ditto.

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

---
 gcc/ada/sem_aggr.adb | 415 +++++++++++++++++++++++++++++++++++++++----
 1 file changed, 384 insertions(+), 31 deletions(-)

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 1dbde1fae31..bc53ea904a3 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -102,6 +102,11 @@ package body Sem_Aggr is
    --  simple insertion sort is used since the choices in a case statement will
    --  usually be in near sorted order.
 
+   function Cannot_Compute_High_Bound (Index : Entity_Id) return Boolean;
+   --  Determines if the type of the given array aggregate index is a modular
+   --  type or an enumeration type that will raise CE at runtime when computing
+   --  the high bound of a null aggregate.
+
    procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
    --  Ada 2005 (AI-231): Check bad usage of null for a component for which
    --  null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for
@@ -121,6 +126,13 @@ package body Sem_Aggr is
    --  Expression is also OK in an instance or inlining context, because we
    --  have already preanalyzed and it is known to be type correct.
 
+   procedure Report_Null_Array_Constraint_Error
+     (N         : Node_Id;
+      Index_Typ : Entity_Id);
+   --  N is a null array aggregate indexed by the given enumeration type or
+   --  modular type. Report a warning notifying that CE will be raised at
+   --  runtime. Under SPARK mode an error is reported instead of a warning.
+
    ------------------------------------------------------
    -- Subprograms used for RECORD AGGREGATE Processing --
    ------------------------------------------------------
@@ -513,27 +525,108 @@ package body Sem_Aggr is
 
          if Dim < Aggr_Dimension then
 
-            --  Process positional components
+            if not Is_Null_Aggregate (N) then
 
-            if Present (Expressions (N)) then
-               Expr := First (Expressions (N));
-               while Present (Expr) loop
-                  Collect_Aggr_Bounds (Expr, Dim + 1);
-                  Next (Expr);
-               end loop;
-            end if;
+               --  Process positional components
+
+               if Present (Expressions (N)) then
+                  Expr := First (Expressions (N));
+                  while Present (Expr) loop
+                     Collect_Aggr_Bounds (Expr, Dim + 1);
+                     Next (Expr);
+                  end loop;
+               end if;
 
-            --  Process component associations
+               --  Process component associations
 
-            if Present (Component_Associations (N)) then
-               Is_Fully_Positional := False;
+               if Present (Component_Associations (N)) then
+                  Is_Fully_Positional := False;
 
-               Assoc := First (Component_Associations (N));
-               while Present (Assoc) loop
-                  Expr := Expression (Assoc);
-                  Collect_Aggr_Bounds (Expr, Dim + 1);
-                  Next (Assoc);
-               end loop;
+                  Assoc := First (Component_Associations (N));
+                  while Present (Assoc) loop
+                     Expr := Expression (Assoc);
+                     Collect_Aggr_Bounds (Expr, Dim + 1);
+
+                     --  Propagate the error; it is not done in other cases to
+                     --  avoid replacing this aggregate by a CE node (required
+                     --  to report complementary warnings when the expression
+                     --  is resolved).
+
+                     if Is_Null_Aggregate (Expr)
+                       and then Raises_Constraint_Error (Expr)
+                     then
+                        Set_Raises_Constraint_Error (N);
+                     end if;
+
+                     Next (Assoc);
+                  end loop;
+               end if;
+
+            --  For null aggregates, build the bounds of their inner dimensions
+            --  (if not previously done). They are required for building the
+            --  aggregate itype.
+
+            elsif No (Aggr_Range (Dim + 1)) then
+               declare
+                  Loc        : constant Source_Ptr := Sloc (N);
+                  Typ        : constant Entity_Id := Etype (N);
+                  Index      : Node_Id;
+                  Index_Typ  : Entity_Id;
+                  Lo, Hi     : Node_Id;
+                  Null_Range : Node_Id;
+                  Num_Dim    : Pos := 1;
+
+               begin
+                  --  Move the index to the first dimension implicitly included
+                  --  in this null aggregate.
+
+                  Index := First_Index (Typ);
+                  while Num_Dim <= Dim loop
+                     Next_Index (Index);
+                     Num_Dim := Num_Dim + 1;
+                  end loop;
+
+                  while Present (Index) loop
+                     Get_Index_Bounds (Index, L => Lo, H => Hi);
+                     Index_Typ := Etype (Index);
+
+                     if Cannot_Compute_High_Bound (Index) then
+                        --  To avoid reporting spurious errors we use the upper
+                        --  bound as the higger bound of this index; this value
+                        --  will not be used to generate code because this
+                        --  aggregate will be replaced by a raise CE node.
+
+                        Hi := New_Copy_Tree (Lo);
+
+                        if not Raises_Constraint_Error (N) then
+                           Report_Null_Array_Constraint_Error (N, Index_Typ);
+                           Set_Raises_Constraint_Error (N);
+                        end if;
+
+                     else
+                        --  The upper bound is the predecessor of the lower
+                        --  bound.
+
+                        Hi := Make_Attribute_Reference (Loc,
+                                Prefix => New_Occurrence_Of (Index_Typ, Loc),
+                                Attribute_Name => Name_Pred,
+                                Expressions => New_List (New_Copy_Tree (Lo)));
+                     end if;
+
+                     Null_Range := Make_Range (Loc, New_Copy_Tree (Lo), Hi);
+                     Analyze_And_Resolve (Null_Range, Index_Typ);
+
+                     pragma Assert (No (Aggr_Range (Num_Dim)));
+                     Aggr_Low (Num_Dim)   := Low_Bound (Null_Range);
+                     Aggr_High (Num_Dim)  := High_Bound (Null_Range);
+                     Aggr_Range (Num_Dim) := Null_Range;
+
+                     Num_Dim := Num_Dim + 1;
+                     Next_Index (Index);
+                  end loop;
+
+                  pragma Assert (Num_Dim = Aggr_Dimension + 1);
+               end;
             end if;
          end if;
       end Collect_Aggr_Bounds;
@@ -552,7 +645,7 @@ package body Sem_Aggr is
       --  Make sure that the list of index constraints is properly attached to
       --  the tree, and then collect the aggregate bounds.
 
-      --  If no aggregaate bounds have been set, this is an aggregate with
+      --  If no aggregate bounds have been set, this is an aggregate with
       --  iterator specifications and a dynamic size to be determined by
       --  first pass of expanded code.
 
@@ -685,6 +778,41 @@ package body Sem_Aggr is
       return Itype;
    end Array_Aggr_Subtype;
 
+   -------------------------------
+   -- Cannot_Compute_High_Bound --
+   -------------------------------
+
+   function Cannot_Compute_High_Bound (Index : Entity_Id) return Boolean is
+      Index_Type : constant Entity_Id := Etype (Index);
+      Lo, Hi     : Node_Id;
+
+   begin
+      if not Is_Modular_Integer_Type (Index_Type)
+        and then not Is_Enumeration_Type (Index_Type)
+      then
+         return False;
+
+      elsif Index_Type = Base_Type (Index_Type) then
+         return True;
+
+      else
+         Get_Index_Bounds (Index, L => Lo, H => Hi);
+
+         if Compile_Time_Known_Value (Lo) then
+            if Is_Enumeration_Type (Index_Type)
+              and then not Is_Character_Type (Index_Type)
+            then
+               return Enumeration_Pos (Entity (Lo))
+                 = Enumeration_Pos (First_Literal (Base_Type (Index_Type)));
+            else
+               return Expr_Value (Lo) = Uint_0;
+            end if;
+         end if;
+      end if;
+
+      return False;
+   end Cannot_Compute_High_Bound;
+
    --------------------------------
    -- Check_Misspelled_Component --
    --------------------------------
@@ -979,6 +1107,27 @@ package body Sem_Aggr is
       Rewrite (N, New_N);
    end Make_String_Into_Aggregate;
 
+   ----------------------------------------
+   -- Report_Null_Array_Constraint_Error --
+   ----------------------------------------
+
+   procedure Report_Null_Array_Constraint_Error
+     (N         : Node_Id;
+      Index_Typ : Entity_Id) is
+   begin
+      Error_Msg_Warn := SPARK_Mode /= On;
+
+      if Is_Modular_Integer_Type (Index_Typ) then
+         Error_Msg_N
+           ("null array aggregate indexed by a modular type<<", N);
+      else
+         Error_Msg_N
+           ("null array aggregate indexed by an enumeration type<<", N);
+      end if;
+
+      Error_Msg_N ("\Constraint_Error [<<", N);
+   end Report_Null_Array_Constraint_Error;
+
    -----------------------
    -- Resolve_Aggregate --
    -----------------------
@@ -1459,6 +1608,11 @@ package body Sem_Aggr is
       --  cannot statically evaluate From. Otherwise it stores this static
       --  value into Value.
 
+      function Has_Null_Aggregate_Raising_Constraint_Error
+        (Expr : Node_Id) return Boolean;
+      --  Determines if the given expression has some null aggregate that will
+      --  cause raising CE at runtime.
+
       function Resolve_Aggr_Expr
         (Expr        : Node_Id;
          Single_Elmt : Boolean) return Boolean;
@@ -1478,6 +1632,11 @@ package body Sem_Aggr is
          Index_Typ : Entity_Id);
       --  For AI12-061
 
+      function Subtract (Val : Uint; To : Node_Id) return Node_Id;
+      --  Creates a new expression node where Val is subtracted to expression
+      --  To. Tries to constant fold whenever possible. To must be an already
+      --  analyzed expression.
+
       procedure Warn_On_Null_Component_Association (Expr : Node_Id);
       --  Expr is either a conditional expression or a case expression of an
       --  iterated component association initializing the aggregate N with
@@ -1747,6 +1906,41 @@ package body Sem_Aggr is
          end if;
       end Get;
 
+      -------------------------------------------------
+      -- Has_Null_Aggregate_Raising_Constraint_Error --
+      -------------------------------------------------
+
+      function Has_Null_Aggregate_Raising_Constraint_Error
+        (Expr : Node_Id) return Boolean
+      is
+         function Process (N : Node_Id) return Traverse_Result;
+         --  Process one node in search for generic formal type
+
+         -------------
+         -- Process --
+         -------------
+
+         function Process (N : Node_Id) return Traverse_Result is
+         begin
+            if Nkind (N) = N_Aggregate
+              and then Is_Null_Aggregate (N)
+              and then Raises_Constraint_Error (N)
+            then
+               return Abandon;
+            end if;
+
+            return OK;
+         end Process;
+
+         function Traverse is new Traverse_Func (Process);
+         --  Traverse tree to look for null aggregates that will raise CE
+
+      --  Start of processing for Has_Null_Aggregate_Raising_Constraint_Error
+
+      begin
+         return Traverse (Expr) = Abandon;
+      end Has_Null_Aggregate_Raising_Constraint_Error;
+
       -----------------------
       -- Resolve_Aggr_Expr --
       -----------------------
@@ -1871,7 +2065,8 @@ package body Sem_Aggr is
          end if;
 
          if Raises_Constraint_Error (Expr)
-           and then Nkind (Parent (Expr)) /= N_Component_Association
+           and then (Nkind (Parent (Expr)) /= N_Component_Association
+                      or else Is_Null_Aggregate (Expr))
          then
             Set_Raises_Constraint_Error (N);
          end if;
@@ -2017,6 +2212,108 @@ package body Sem_Aggr is
          End_Scope;
       end Resolve_Iterated_Component_Association;
 
+      --------------
+      -- Subtract --
+      --------------
+
+      function Subtract (Val : Uint; To : Node_Id) return Node_Id is
+         Expr_Pos : Node_Id;
+         Expr     : Node_Id;
+         To_Pos   : Node_Id;
+
+      begin
+         if Raises_Constraint_Error (To) then
+            return To;
+         end if;
+
+         --  First test if we can do constant folding
+
+         if Compile_Time_Known_Value (To)
+           or else Nkind (To) = N_Integer_Literal
+         then
+            Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) - Val);
+            Set_Is_Static_Expression (Expr_Pos);
+            Set_Etype (Expr_Pos, Etype (To));
+            Set_Analyzed (Expr_Pos, Analyzed (To));
+
+            if not Is_Enumeration_Type (Index_Typ) then
+               Expr := Expr_Pos;
+
+            --  If we are dealing with enumeration return
+            --     Index_Typ'Val (Expr_Pos)
+
+            else
+               Expr :=
+                 Make_Attribute_Reference
+                   (Loc,
+                    Prefix         => New_Occurrence_Of (Index_Typ, Loc),
+                    Attribute_Name => Name_Val,
+                    Expressions    => New_List (Expr_Pos));
+            end if;
+
+            return Expr;
+         end if;
+
+         --  If we are here no constant folding possible
+
+         if not Is_Enumeration_Type (Index_Base) then
+            Expr :=
+              Make_Op_Subtract (Loc,
+                Left_Opnd  => Duplicate_Subexpr (To),
+                Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+         --  If we are dealing with enumeration return
+         --    Index_Typ'Val (Index_Typ'Pos (To) - Val)
+
+         else
+            To_Pos :=
+              Make_Attribute_Reference
+                (Loc,
+                 Prefix         => New_Occurrence_Of (Index_Typ, Loc),
+                 Attribute_Name => Name_Pos,
+                 Expressions    => New_List (Duplicate_Subexpr (To)));
+
+            Expr_Pos :=
+              Make_Op_Subtract (Loc,
+                Left_Opnd  => To_Pos,
+                Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+            Expr :=
+              Make_Attribute_Reference
+                (Loc,
+                 Prefix         => New_Occurrence_Of (Index_Typ, Loc),
+                 Attribute_Name => Name_Val,
+                 Expressions    => New_List (Expr_Pos));
+
+            --  If the index type has a non standard representation, the
+            --  attributes 'Val and 'Pos expand into function calls and the
+            --  resulting expression is considered non-safe for reevaluation
+            --  by the backend. Relocate it into a constant temporary in order
+            --  to make it safe for reevaluation.
+
+            if Has_Non_Standard_Rep (Etype (N)) then
+               declare
+                  Def_Id : Entity_Id;
+
+               begin
+                  Def_Id := Make_Temporary (Loc, 'R', Expr);
+                  Set_Etype (Def_Id, Index_Typ);
+                  Insert_Action (N,
+                    Make_Object_Declaration (Loc,
+                      Defining_Identifier => Def_Id,
+                      Object_Definition   =>
+                        New_Occurrence_Of (Index_Typ, Loc),
+                      Constant_Present    => True,
+                      Expression          => Relocate_Node (Expr)));
+
+                  Expr := New_Occurrence_Of (Def_Id, Loc);
+               end;
+            end if;
+         end if;
+
+         return Expr;
+      end Subtract;
+
       ----------------------------------------
       -- Warn_On_Null_Component_Association --
       ----------------------------------------
@@ -2726,6 +3023,19 @@ package body Sem_Aggr is
                      Related_Nod => N);
                end if;
 
+               --  Propagate the attribute Raises_CE when it was reported on a
+               --  null aggregate. This will cause replacing the aggregate by a
+               --  raise CE node; it is not done in other cases to avoid such
+               --  replacement and report complementary warnings when the
+               --  expression is resolved.
+
+               if Present (Expression (Assoc))
+                 and then Has_Null_Aggregate_Raising_Constraint_Error
+                            (Expression (Assoc))
+               then
+                  Set_Raises_Constraint_Error (N);
+               end if;
+
                Next (Assoc);
             end loop;
 
@@ -3208,8 +3518,32 @@ package body Sem_Aggr is
                Aggr_Low := Index_Typ_Low;
             end if;
 
-            Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
-            Check_Bound (Index_Base_High, Aggr_High);
+            --  Report a warning when the index type of a null array aggregate
+            --  is a modular type or an enumeration type, and we know that
+            --  we will not be able to compute its high bound at runtime
+            --  (AI22-0100-2).
+
+            if Nb_Elements = Uint_0
+              and then Cannot_Compute_High_Bound (Index_Constr)
+            then
+               --  Use the low bound value for the high-bound value to avoid
+               --  reporting spurious errors; this value will not be used at
+               --  runtime because this aggregate will be replaced by a raise
+               --  CE node.
+
+               Aggr_High := Aggr_Low;
+
+               Report_Null_Array_Constraint_Error (N, Index_Typ);
+               Set_Raises_Constraint_Error (N);
+
+            elsif Nb_Elements = Uint_0 then
+               Aggr_High := Subtract (Uint_1, To => Aggr_Low);
+               Check_Bound (Index_Base_High, Aggr_High);
+
+            else
+               Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
+               Check_Bound (Index_Base_High, Aggr_High);
+            end if;
          end if;
       end if;
 
@@ -4726,9 +5060,11 @@ package body Sem_Aggr is
       Loc    : constant Source_Ptr := Sloc (N);
       Typ    : constant Entity_Id := Etype (N);
 
-      Index  : Node_Id;
-      Lo, Hi : Node_Id;
-      Constr : constant List_Id := New_List;
+      Constr       : constant List_Id := New_List;
+      Index        : Node_Id;
+      Index_Typ    : Node_Id;
+      Known_Bounds : Boolean := True;
+      Lo, Hi       : Node_Id;
 
    begin
       --  Attach the list of constraints at the location of the aggregate, so
@@ -4742,14 +5078,31 @@ package body Sem_Aggr is
       Index := First_Index (Typ);
       while Present (Index) loop
          Get_Index_Bounds (Index, L => Lo, H => Hi);
+         Index_Typ := Etype (Index);
+
+         Known_Bounds := Known_Bounds
+           and Compile_Time_Known_Value (Lo)
+           and Compile_Time_Known_Value (Hi);
 
-         --  The upper bound is the predecessor of the lower bound
+         if Cannot_Compute_High_Bound (Index) then
+            --  The upper bound is the higger bound to avoid reporting
+            --  spurious errors; this value will not be used at runtime
+            --  because this aggregate will be replaced by a raise CE node,
+            --  or the index type is formal of a generic unit.
 
-         Hi := Make_Attribute_Reference
-            (Loc,
-             Prefix         => New_Occurrence_Of (Etype (Index), Loc),
-             Attribute_Name => Name_Pred,
-             Expressions    => New_List (New_Copy_Tree (Lo)));
+            Hi := New_Copy_Tree (Lo);
+
+            Report_Null_Array_Constraint_Error (N, Index_Typ);
+            Set_Raises_Constraint_Error (N);
+
+         else
+            --  The upper bound is the predecessor of the lower bound
+
+            Hi := Make_Attribute_Reference (Loc,
+                    Prefix         => New_Occurrence_Of (Etype (Index), Loc),
+                    Attribute_Name => Name_Pred,
+                    Expressions    => New_List (New_Copy_Tree (Lo)));
+         end if;
 
          Append (Make_Range (Loc, New_Copy_Tree (Lo), Hi), Constr);
          Analyze_And_Resolve (Last (Constr), Etype (Index));
@@ -4757,7 +5110,7 @@ package body Sem_Aggr is
          Next_Index (Index);
       end loop;
 
-      Set_Compile_Time_Known_Aggregate (N);
+      Set_Compile_Time_Known_Aggregate (N, Known_Bounds);
       Set_Aggregate_Bounds (N, First (Constr));
 
       return True;
-- 
2.45.2

[COMMITTED 04/13] ada: Fix bogus error on allocator in instantiation with private derived types

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

The problem is that the call to Convert_View made from Make_Init_Call does
nothing because the Etype is not set on the second argument.

gcc/ada/

	* exp_ch7.adb (Convert_View): Add third parameter Typ and use it if
	the second parameter does not have an Etype.
	(Make_Adjust_Call): Remove obsolete setting of Etype and pass Typ in
	call to Convert_View.
	(Make_Final_Call): Likewise.
	(Make_Init_Call): Pass Typ in call to Convert_View.

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

---
 gcc/ada/exp_ch7.adb | 51 +++++++++++++++++++--------------------------
 1 file changed, 21 insertions(+), 30 deletions(-)

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 149715f94da..f4a707034c1 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -563,12 +563,16 @@ package body Exp_Ch7 is
    --  Check recursively whether a loop or block contains a subprogram that
    --  may need an activation record.
 
-   function Convert_View (Proc : Entity_Id; Arg  : Node_Id) return Node_Id;
-   --  Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
-   --  argument being passed to it. This function will, if necessary, generate
-   --  a conversion between the partial and full view of Arg to match the type
-   --  of the formal of Proc, or force a conversion to the class-wide type in
-   --  the case where the operation is abstract.
+   function Convert_View
+     (Proc : Entity_Id;
+      Arg  : Node_Id;
+      Typ  : Entity_Id) return Node_Id;
+   --  Proc is one of the Initialize/Adjust/Finalize operations, Arg is the one
+   --  argument being passed to it, and Typ is its expected type. This function
+   --  will, if necessary, generate a conversion between the partial and full
+   --  views of Arg to match the type of the formal of Proc, or else force a
+   --  conversion to the class-wide type in the case where the operation is
+   --  abstract.
 
    function Make_Call
      (Loc       : Source_Ptr;
@@ -4023,7 +4027,11 @@ package body Exp_Ch7 is
    -- Convert_View --
    ------------------
 
-   function Convert_View (Proc : Entity_Id; Arg  : Node_Id) return Node_Id is
+   function Convert_View
+     (Proc : Entity_Id;
+      Arg  : Node_Id;
+      Typ  : Entity_Id) return Node_Id
+   is
       Ftyp : constant Entity_Id := Etype (First_Formal (Proc));
 
       Atyp : Entity_Id;
@@ -4031,8 +4039,10 @@ package body Exp_Ch7 is
    begin
       if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
          Atyp := Entity (Subtype_Mark (Arg));
-      else
+      elsif Present (Etype (Arg)) then
          Atyp := Etype (Arg);
+      else
+         Atyp := Typ;
       end if;
 
       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
@@ -5452,21 +5462,11 @@ package body Exp_Ch7 is
       end if;
 
       if Present (Adj_Id) then
-
-         --  If the object is unanalyzed, set its expected type for use in
-         --  Convert_View in case an additional conversion is needed.
-
-         if No (Etype (Ref))
-           and then Nkind (Ref) /= N_Unchecked_Type_Conversion
-         then
-            Set_Etype (Ref, Typ);
-         end if;
-
          --  The object reference may need another conversion depending on the
          --  type of the formal and that of the actual.
 
          if not Is_Class_Wide_Type (Typ) then
-            Ref := Convert_View (Adj_Id, Ref);
+            Ref := Convert_View (Adj_Id, Ref, Typ);
          end if;
 
          return
@@ -7849,16 +7849,7 @@ package body Exp_Ch7 is
                end if;
             end;
 
-            --  If the object is unanalyzed, set its expected type for use in
-            --  Convert_View in case an additional conversion is needed.
-
-            if No (Etype (Ref))
-              and then Nkind (Ref) /= N_Unchecked_Type_Conversion
-            then
-               Set_Etype (Ref, Typ);
-            end if;
-
-            Ref := Convert_View (Fin_Id, Ref);
+            Ref := Convert_View (Fin_Id, Ref, Typ);
          end if;
 
          return
@@ -8314,7 +8305,7 @@ package body Exp_Ch7 is
       --  The object reference may need another conversion depending on the
       --  type of the formal and that of the actual.
 
-      Ref := Convert_View (Proc, Ref);
+      Ref := Convert_View (Proc, Ref, Typ);
 
       --  Generate:
       --    [Deep_]Initialize (Ref);
-- 
2.45.2

[COMMITTED 05/13] ada: Fix analysis of Extensions_Visible

[Marc Poulhiès]

From: Yannick Moy <moy@adacore.com>

Pragma/aspect Extensions_Visible should be analyzed before any
pre/post contracts on a subprogram, as the legality of conversions
of formal parameters to classwide type depends on the value of
Extensions_Visible. Now fixed.

gcc/ada/

	* contracts.adb (Analyze_Pragmas_In_Declarations): Analyze
	pragmas in two iterations over the list of declarations in
	order to analyze some pragmas before others.
	* einfo-utils.ads (Get_Pragma): Fix comment.
	* sem_prag.ads (Pragma_Significant_To_Subprograms): Fix.
	(Pragma_Significant_To_Subprograms_Analyzed_First): Add new
	global array to identify these pragmas which should be analyzed
	first, which concerns only Extensions_Visible for now.

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

---
 gcc/ada/contracts.adb   | 46 ++++++++++++++++++++++++-----------------
 gcc/ada/einfo-utils.ads |  1 +
 gcc/ada/sem_prag.ads    | 10 +++++++++
 3 files changed, 38 insertions(+), 19 deletions(-)

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 9fc9e05db68..a93bf622aa1 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -546,33 +546,41 @@ package body Contracts is
 
    begin
       --  Move through the body's declarations analyzing all pragmas which
-      --  appear at the top of the declarations.
+      --  appear at the top of the declarations. Go over the list twice, so
+      --  that pragmas which should be analyzed first are analyzed in the
+      --  first pass.
 
-      Curr_Decl := First (Declarations (Unit_Declaration_Node (Body_Id)));
-      while Present (Curr_Decl) loop
+      for Pragmas_Analyzed_First in reverse False .. True loop
 
-         if Nkind (Curr_Decl) = N_Pragma then
+         Curr_Decl := First (Declarations (Unit_Declaration_Node (Body_Id)));
+         while Present (Curr_Decl) loop
 
-            if Pragma_Significant_To_Subprograms
-                 (Get_Pragma_Id (Curr_Decl))
-            then
-               Analyze (Curr_Decl);
-            end if;
+            if Nkind (Curr_Decl) = N_Pragma then
 
-         --  Skip the renamings of discriminants and protection fields
+               if Pragma_Significant_To_Subprograms
+                    (Get_Pragma_Id (Curr_Decl))
+                 and then Pragmas_Analyzed_First =
+                   Pragma_Significant_To_Subprograms_Analyzed_First
+                     (Get_Pragma_Id (Curr_Decl))
+               then
+                  Analyze (Curr_Decl);
+               end if;
 
-         elsif Is_Prologue_Renaming (Curr_Decl) then
-            null;
+            --  Skip the renamings of discriminants and protection fields
 
-         --  We have reached something which is not a pragma so we can be sure
-         --  there are no more contracts or pragmas which need to be taken into
-         --  account.
+            elsif Is_Prologue_Renaming (Curr_Decl) then
+               null;
 
-         else
-            exit;
-         end if;
+            --  We have reached something which is not a pragma so we can be
+            --  sure there are no more contracts or pragmas which need to be
+            --  taken into account.
+
+            else
+               exit;
+            end if;
 
-         Next (Curr_Decl);
+            Next (Curr_Decl);
+         end loop;
       end loop;
    end Analyze_Pragmas_In_Declarations;
 
diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
index 01953c35bc3..8207576fb89 100644
--- a/gcc/ada/einfo-utils.ads
+++ b/gcc/ada/einfo-utils.ads
@@ -448,6 +448,7 @@ package Einfo.Utils is
    --    Effective_Reads
    --    Effective_Writes
    --    Exceptional_Cases
+   --    Extensions_Visible
    --    Global
    --    Initial_Condition
    --    Initializes
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 59220ea890c..557e0454870 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -216,6 +216,7 @@ package Sem_Prag is
       Pragma_Contract_Cases      => True,
       Pragma_Depends             => True,
       Pragma_Exceptional_Cases   => True,
+      Pragma_Extensions_Visible  => True,
       Pragma_Ghost               => True,
       Pragma_Global              => True,
       Pragma_Inline              => True,
@@ -238,6 +239,15 @@ package Sem_Prag is
       Pragma_Volatile_Function   => True,
       others                     => False);
 
+   --  The following table lists all pragmas which are relevant to the analysis
+   --  of subprogram bodies and should be analyzed first, because the analysis
+   --  of other pragmas relevant to subprogram bodies depend on them.
+
+   Pragma_Significant_To_Subprograms_Analyzed_First :
+     constant array (Pragma_Id) of Boolean :=
+     (Pragma_Extensions_Visible => True,
+      others                    => False);
+
    -----------------
    -- Subprograms --
    -----------------
-- 
2.45.2

[COMMITTED 06/13] ada: Call memcmp instead of Compare_Array_Unsigned_8 and...

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

... implement support for ordering comparisons of discrete array types.

This extends the Support_Composite_Compare_On_Target feature to ordering
comparisons of discrete array types as specified by RM 4.5.2(26/3), when
the component type is a byte (unsigned).

Implement support for ordering comparisons of discrete array types
with a two-pronged approach: for types with a size known at compile time,
this lets the gimplifier generate the call to memcmp (or else an optimize
version of it); otherwise, this directly generates the call to memcmp.

gcc/ada/

	* exp_ch4.adb (Expand_Array_Comparison): Remove the obsolete byte
	addressibility test. If Support_Composite_Compare_On_Target is true,
	immediately return for a component size of 8, an unsigned component
	type and aligned operands. Disable when Unnest_Subprogram_Mode is
	true (for LLVM).
	(Expand_N_Op_Eq): Adjust comment.
	* targparm.ads (Support_Composite_Compare_On_Target): Replace bit by
	byte in description and document support for ordering comparisons.
	* gcc-interface/utils2.cc (compare_arrays): Rename into...
	(compare_arrays_for_equality): ...this.  Remove redundant lines.
	(compare_arrays_for_ordering): New function.
	(build_binary_op) <comparisons>: Call compare_arrays_for_ordering
	to implement ordering comparisons for arrays.

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

---
 gcc/ada/exp_ch4.adb             |  41 ++++++-----
 gcc/ada/gcc-interface/utils2.cc | 122 ++++++++++++++++++++++++++++----
 gcc/ada/targparm.ads            |  11 +--
 3 files changed, 138 insertions(+), 36 deletions(-)

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 6a33734c443..e4c9de474ad 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1162,9 +1162,6 @@ package body Exp_Ch4 is
 
       Comp : RE_Id;
 
-      Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
-      --  True for byte addressable target
-
       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
       --  Returns True if the length of the given operand is known to be less
       --  than 4. Returns False if this length is known to be four or greater
@@ -1198,11 +1195,12 @@ package body Exp_Ch4 is
    --  Start of processing for Expand_Array_Comparison
 
    begin
-      --  Deal first with unpacked case, where we can call a runtime routine
-      --  except that we avoid this for targets for which are not addressable
-      --  by bytes.
+      --  Deal first with unpacked case, where we can call a runtime routine,
+      --  except if the component type is a byte (unsigned) where we can use
+      --  a byte-wise comparison if supported on the target (this is disabled
+      --  for now in Unnest_Subprogram_Mode for LLVM).
 
-      if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable then
+      if not Is_Bit_Packed_Array (Typ1) then
          --  The call we generate is:
 
          --  Compare_Array_xn[_Unaligned]
@@ -1214,9 +1212,18 @@ package body Exp_Ch4 is
          --  <op> is the standard comparison operator
 
          if Component_Size (Typ1) = 8 then
-            if Length_Less_Than_4 (Op1)
-                 or else
-               Length_Less_Than_4 (Op2)
+            if Is_Unsigned_Type (Ctyp)
+              and then not Is_Possibly_Unaligned_Object (Op1)
+              and then not Is_Possibly_Unaligned_Slice (Op1)
+              and then not Is_Possibly_Unaligned_Object (Op2)
+              and then not Is_Possibly_Unaligned_Slice (Op2)
+              and then Support_Composite_Compare_On_Target
+              and then not Unnest_Subprogram_Mode
+            then
+               return;
+
+            elsif Length_Less_Than_4 (Op1)
+              or else Length_Less_Than_4 (Op2)
             then
                if Is_Unsigned_Type (Ctyp) then
                   Comp := RE_Compare_Array_U8_Unaligned;
@@ -1261,11 +1268,10 @@ package body Exp_Ch4 is
             end if;
          end if;
 
-         if RTE_Available (Comp) then
-
-            --  Expand to a call only if the runtime function is available,
-            --  otherwise fall back to inline code.
+         --  Expand to a call only if the runtime function is available,
+         --  otherwise fall back to inline code.
 
+         if RTE_Available (Comp) then
             Remove_Side_Effects (Op1, Name_Req => True);
             Remove_Side_Effects (Op2, Name_Req => True);
 
@@ -1292,8 +1298,7 @@ package body Exp_Ch4 is
                        Attribute_Name => Name_Length)));
 
                Zero : constant Node_Id :=
-                 Make_Integer_Literal (Loc,
-                   Intval => Uint_0);
+                 Make_Integer_Literal (Loc, Intval => Uint_0);
 
                Comp_Op : Node_Id;
 
@@ -8230,8 +8235,8 @@ package body Exp_Ch4 is
          then
             Expand_Packed_Eq (N);
 
-         --  Where the component type is elementary we can use a block bit
-         --  comparison (if supported on the target) exception in the case
+         --  When the component type is elementary, we can use a byte-wise
+         --  comparison if supported on the target, except in the cases
          --  of floating-point (negative zero issues require element by
          --  element comparison), and full access types (where we must be sure
          --  to load elements independently) and possibly unaligned arrays.
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index d101d7729bf..0d7e03ec6b0 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -283,7 +283,7 @@ find_common_type (tree t1, tree t2)
    tests in as efficient a manner as possible.  */
 
 static tree
-compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
+compare_arrays_for_equality (location_t loc, tree result_type, tree a1, tree a2)
 {
   tree result = convert (result_type, boolean_true_node);
   tree a1_is_null = convert (result_type, boolean_false_node);
@@ -357,8 +357,6 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
 	  ub1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (ub1, a1);
 
 	  comparison = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1);
-	  if (EXPR_P (comparison))
-	    SET_EXPR_LOCATION (comparison, loc);
 
 	  this_a1_is_null = comparison;
 	  this_a2_is_null = convert (result_type, boolean_true_node);
@@ -380,9 +378,6 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
 						ub1, lb1),
 			       build_binary_op (MINUS_EXPR, base_type,
 						ub2, lb2));
-	  if (EXPR_P (comparison))
-	    SET_EXPR_LOCATION (comparison, loc);
-
 	  this_a1_is_null
 	    = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1);
 
@@ -397,8 +392,6 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
 
 	  comparison
 	    = fold_build2_loc (loc, EQ_EXPR, result_type, length1, length2);
-	  if (EXPR_P (comparison))
-	    SET_EXPR_LOCATION (comparison, loc);
 
 	  lb1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (lb1, a1);
 	  ub1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (ub1, a1);
@@ -464,6 +457,89 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2)
   return result;
 }
 
+/* Return an expression tree representing an ordering comparison of A1 and A2,
+   two objects of type ARRAY_TYPE.  The result should be of type RESULT_TYPE.
+
+   A1 is less than A2 according to the following alternative:
+     - when A1's length is less than A2'length: if every element of A1 is equal
+       to its counterpart in A2 or the first differing is lesser in A1 than A2,
+     - otherwise: if not every element of A2 is equal to its counterpart in A1
+       and the first differing is lesser in A1 than A2.
+
+   The other 3 ordering comparisons can be easily deduced from this one.  */
+
+static tree
+compare_arrays_for_ordering (location_t loc, tree result_type, tree a1, tree a2)
+{
+  const bool a1_side_effects_p = TREE_SIDE_EFFECTS (a1);
+  const bool a2_side_effects_p = TREE_SIDE_EFFECTS (a2);
+  tree t1 = TREE_TYPE (a1);
+  tree t2 = TREE_TYPE (a2);
+  tree dom1 = TYPE_DOMAIN (t1);
+  tree dom2 = TYPE_DOMAIN (t2);
+  tree length1 = size_binop (PLUS_EXPR,
+			     size_binop (MINUS_EXPR,
+					 TYPE_MAX_VALUE (dom1),
+					 TYPE_MIN_VALUE (dom1)),
+			     size_one_node);
+  tree length2 = size_binop (PLUS_EXPR,
+			     size_binop (MINUS_EXPR,
+					 TYPE_MAX_VALUE (dom2),
+					 TYPE_MIN_VALUE (dom2)),
+			     size_one_node);
+  tree addr1, addr2, fndecl, result;
+
+  /* If the lengths are known at compile time, fold the alternative and let the
+     gimplifier optimize the case of power-of-two lengths.  */
+  if (TREE_CODE (length1) == INTEGER_CST && TREE_CODE (length2) == INTEGER_CST)
+    return tree_int_cst_compare (length1, length2) < 0
+	   ? fold_build2_loc (loc, LE_EXPR, result_type, a1, convert (t1, a2))
+	   : fold_build2_loc (loc, LT_EXPR, result_type, convert (t2, a1), a2);
+
+  /* If the operands have side-effects, they need to be evaluated only once
+     in spite of the multiple references in the comparison.  */
+  if (a1_side_effects_p)
+    a1 = gnat_protect_expr (a1);
+
+  if (a2_side_effects_p)
+    a2 = gnat_protect_expr (a2);
+
+  length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
+  length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2);
+
+  /* If the lengths are not known at compile time, call memcmp directly with
+     the actual lengths since a1 and a2 may have the same nominal subtype.  */
+  addr1 = build_fold_addr_expr_loc (loc, a1);
+  addr2 = build_fold_addr_expr_loc (loc, a2);
+  fndecl = builtin_decl_implicit (BUILT_IN_MEMCMP);
+
+  result
+    = fold_build3_loc (loc, COND_EXPR, result_type,
+		       fold_build2_loc (loc, LT_EXPR, boolean_type_node,
+				        length1, length2),
+		       fold_build2_loc (loc, LE_EXPR, result_type,
+				        build_call_expr_loc (loc, fndecl, 3,
+							     addr1, addr2,
+							     length1),
+					integer_zero_node),
+		       fold_build2_loc (loc, LT_EXPR, result_type,
+					build_call_expr_loc (loc, fndecl, 3,
+							     addr1, addr2,
+							     length2),
+					integer_zero_node));
+
+  /* If the operands have side-effects, they need to be evaluated before
+     doing the tests above since the place they otherwise would end up
+     being evaluated at run time could be wrong.  */
+  if (a1_side_effects_p)
+    result = build2 (COMPOUND_EXPR, result_type, a1, result);
+
+  if (a2_side_effects_p)
+    result = build2 (COMPOUND_EXPR, result_type, a2, result);
+
+  return result;
+}
+
 /* Return an expression tree representing an equality comparison of P1 and P2,
    two objects of fat pointer type.  The result should be of type RESULT_TYPE.
 
@@ -1176,12 +1252,32 @@ build_binary_op (enum tree_code op_code, tree result_type,
 	      || (TREE_CODE (right_type) == INTEGER_TYPE
 		  && TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
 	{
-	  result = compare_arrays (input_location,
-				   result_type, left_operand, right_operand);
-	  if (op_code == NE_EXPR)
-	    result = invert_truthvalue_loc (EXPR_LOCATION (result), result);
+          if (op_code == EQ_EXPR || op_code == NE_EXPR)
+	    {
+	      result
+		= compare_arrays_for_equality (input_location, result_type,
+					       left_operand, right_operand);
+	      if (op_code == NE_EXPR)
+		result = invert_truthvalue_loc (input_location, result);
+	    }
+
 	  else
-	    gcc_assert (op_code == EQ_EXPR);
+	    {
+	      /* Swap the operands to canonicalize to LT_EXPR or GE_EXPR.  */
+	      if (op_code == GT_EXPR || op_code == LE_EXPR)
+		result
+		  = compare_arrays_for_ordering (input_location, result_type,
+						 right_operand, left_operand);
+
+	      else
+		result
+		  = compare_arrays_for_ordering (input_location, result_type,
+						 left_operand, right_operand);
+
+	      /* GE_EXPR is (not LT_EXPR) for discrete array types.  */
+	      if (op_code == GE_EXPR || op_code == LE_EXPR)
+		result = invert_truthvalue_loc (input_location, result);
+	    }
 
 	  return result;
 	}
diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads
index 050eb25c12c..323a41dcc8b 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -359,11 +359,12 @@ package Targparm is
    --  the flag is set False, and composite assignments are not allowed.
 
    Support_Composite_Compare_On_Target : Boolean := True;
-   --  If this flag is True, then the back end supports bit-wise comparison
-   --  of composite objects for equality, either generating inline code or
-   --  calling appropriate (and available) run-time routines. If this flag
-   --  is False, then the back end does not provide this support, and the
-   --  front end uses component by component comparison for composites.
+   --  If this flag is True, then the back end supports byte-wise comparison
+   --  of arrays for equality operations and lexicographic comparison of 1-
+   --  dimensional arrays of bytes for ordering operations, either by means
+   --  of generating inline code or calling appropriate routines like memcmp.
+   --  If this flag is False, then the back end does not provide this support,
+   --  and the front end uses component by component comparison for arrays.
 
    Support_Long_Shifts_On_Target : Boolean := True;
    --  If True, the back end supports 64-bit shift operations. If False, then
-- 
2.45.2

[COMMITTED 07/13] ada: Bug box for expression function with list comprehension

[Marc Poulhiès]

From: Bob Duff <duff@adacore.com>

GNAT crashes on an iterator with a filter inside an expression function
that is the completion of an earlier spec.

gcc/ada/

	* freeze.adb (Freeze_Type_Refs): If Node is in N_Has_Etype,
	check that it has had its Etype set, because this can be
	called early for expression functions that are completions.

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

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

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 757c16e6839..7cf7e847677 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -9137,6 +9137,7 @@ package body Freeze is
          --  that type is not attached to an entity in the construct.
 
          elsif Nkind (Node) in N_Has_Etype
+           and then Present (Etype (Node))
            and then Nkind (Parent (Node)) = N_Iterator_Specification
            and then Node = Name (Parent (Node))
          then
-- 
2.45.2

[COMMITTED 08/13] ada: Allow mutably tagged types to work with qualified expressions

[Marc Poulhiès]

From: Justin Squirek <squirek@adacore.com>

This patch modifies the experimental 'Size'Class feature such that objects of
mutably tagged types can be assigned qualified expressions featuring a
definite type (e.g. Mutable_Obj := Root_Child_T'(Root_T with others => <>)).

gcc/ada/

	* sem_ch5.adb:
	(Analyze_Assignment): Add special expansion for qualified expressions
	in certain cases dealing with mutably tagged types.

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

---
 gcc/ada/sem_ch5.adb | 14 ++++++++++++++
 1 file changed, 14 insertions(+)

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 644bd21ce93..5739fe06ea2 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -697,6 +697,19 @@ package body Sem_Ch5 is
       then
          Resolve (Rhs, Base_Type (T1));
 
+      --  When the right hand side is a qualified expression and the left hand
+      --  side is mutably tagged we force the right hand side to be class-wide
+      --  so that they are compatible both for the purposes of checking
+      --  legality rules as well as assignment expansion.
+
+      elsif Is_Mutably_Tagged_Type (T1)
+        and then Nkind (Rhs) = N_Qualified_Expression
+      then
+         Make_Mutably_Tagged_Conversion (Rhs, T1);
+         Resolve (Rhs, T1);
+
+      --  Otherwise, resolve the right hand side normally
+
       else
          Resolve (Rhs, T1);
       end if;
@@ -765,6 +778,7 @@ package body Sem_Ch5 is
         and then not Is_Class_Wide_Type (T2)
         and then not Is_Tag_Indeterminate (Rhs)
         and then not Is_Dynamically_Tagged (Rhs)
+        and then not Is_Mutably_Tagged_Type (T1)
       then
          Error_Msg_N ("dynamically tagged expression required!", Rhs);
       end if;
-- 
2.45.2

[COMMITTED 09/13] ada: Put_Image aspect spec ignored for null extension.

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

If type T1 is is a tagged null record with a Put_Image aspect specification
and type T2 is a null extension of T1 (with no aspect specifications), then
evaluation of a T2'Image call should include a call to the specified procedure
(as opposed to yielding "(NULL RECORD)").

gcc/ada/

	* exp_put_image.adb
	(Build_Record_Put_Image_Procedure): Declare new Boolean-valued
	function Null_Record_Default_Implementation_OK; call it as part of
	deciding whether to generate "(NULL RECORD)" text.

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

---
 gcc/ada/exp_put_image.adb | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 94299e39661..bf14eded93e 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -580,6 +580,18 @@ package body Exp_Put_Image is
       function Make_Component_Name (C : Entity_Id) return Node_Id;
       --  Create a call that prints "Comp_Name => "
 
+      function Null_Record_Default_Implementation_OK
+        (Null_Record_Type : Entity_Id) return Boolean
+      is
+        (if Has_Aspect (Null_Record_Type, Aspect_Put_Image)
+           then False
+         elsif not Is_Derived_Type
+                     (Implementation_Base_Type (Null_Record_Type))
+           then True
+         else Null_Record_Default_Implementation_OK
+                (Implementation_Base_Type (Etype (Null_Record_Type))));
+      --  return True iff ok to emit "(NULL RECORD)" for given null record type
+
       ------------------------------------
       -- Make_Component_List_Attributes --
       ------------------------------------
@@ -852,7 +864,10 @@ package body Exp_Put_Image is
                           Type_Name))));
             end;
          end if;
-      elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
+
+      elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True)
+        and then Null_Record_Default_Implementation_OK (Btyp)
+      then
 
          --  Interface types take this path.
 
-- 
2.45.2

[COMMITTED 10/13] ada: Use clause (or use type clause) in a protected operation sometimes ignored.

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

In some cases, a use clause (or a use type clause) occurring within a
protected operation is incorrectly ignored.

gcc/ada/

	* exp_ch9.adb
	(Expand_N_Protected_Body): Declare new procedure
	Unanalyze_Use_Clauses and call it before analyzing the newly
	constructed subprogram body.

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

---
 gcc/ada/exp_ch9.adb | 41 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 41 insertions(+)

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index a8c70598fa5..939a8e25d5a 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -8316,6 +8316,11 @@ package body Exp_Ch9 is
       --     <protected-procedure-name>P (Param1 .. ParamN);
       --  end <protected-procedure-name>
 
+      procedure Unanalyze_Use_Clauses (Op_Body : Node_Id);
+      --  Use and Use_Type clauses in the tree rooted at Op_Body
+      --  that have already been analyzed need to be marked as unanalyzed
+      --  because otherwise they will be ineffective in their new context.
+
       ---------------------------------------
       -- Build_Dispatching_Subprogram_Body --
       ---------------------------------------
@@ -8377,6 +8382,31 @@ package body Exp_Ch9 is
                Make_Handled_Sequence_Of_Statements (Loc, Stmts));
       end Build_Dispatching_Subprogram_Body;
 
+      ---------------------------
+      -- Unanalyze_Use_Clauses --
+      ---------------------------
+
+      procedure Unanalyze_Use_Clauses (Op_Body : Node_Id) is
+
+         function Process_One_Node (N : Node_Id) return Traverse_Result;
+         --  If N is a use or use type node then unanalyze it.
+
+         procedure Process_Tree is new Traverse_Proc (Process_One_Node);
+
+         function Process_One_Node (N : Node_Id) return Traverse_Result is
+         begin
+            if Nkind (N) in N_Use_Package_Clause | N_Use_Type_Clause then
+               Set_Analyzed (N, False);
+            end if;
+            return OK; --  return Skip if Is_Analyzed (N) ?
+         end Process_One_Node;
+
+      --  Start of processing for Analyze_Use_Clauses
+
+      begin
+         Process_Tree (Op_Body);
+      end Unanalyze_Use_Clauses;
+
    --  Start of processing for Expand_N_Protected_Body
 
    begin
@@ -8426,6 +8456,17 @@ package body Exp_Ch9 is
                        Build_Unprotected_Subprogram_Body (Op_Body, Pid);
                   end if;
 
+                  --  Ugly.
+                  --  We are going to perform name resolution in analysis of
+                  --  this new body, but any already-analyzed use clauses
+                  --  will be ineffective in this new context unless we take
+                  --  action to "reactivate" them. So that's what we do here.
+                  --  We arguably shouldn't be performing name resolution
+                  --  here (just like we shouldn't perform name resolution in
+                  --  an expanded instance body), but that's a larger issue.
+
+                  Unanalyze_Use_Clauses (New_Op_Body);
+
                   Insert_After (Current_Node, New_Op_Body);
                   Current_Node := New_Op_Body;
                   Analyze (New_Op_Body);
-- 
2.45.2

[COMMITTED 11/13] ada: Compiler accepts an illegal Unchecked_Access attribute reference

[Marc Poulhiès]

From: Steve Baird <baird@adacore.com>

The compiler incorrectly accepts Some_Object'Unchecked_Access'Image.

gcc/ada/

	* sem_attr.adb
	(Analyze_Image_Attribute.Check_Image_Type): Check for
	E_Access_Attribute_Type prefix type.

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

---
 gcc/ada/sem_attr.adb | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index d56c25a79cc..0b0adac1126 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1582,6 +1582,13 @@ package body Sem_Attr is
             then
                Error_Msg_Ada_2022_Feature ("nonscalar ''Image", Sloc (P));
                Error_Attr;
+
+            elsif Present (Image_Type)
+              and then Ekind (Image_Type) = E_Access_Attribute_Type
+            then
+               --  reject Some_Object'[Unchecked_]Access'[Wide_[Wide_]]Image
+               Error_Msg_N ("illegal Image attribute prefix", N);
+               Error_Attr;
             end if;
          end Check_Image_Type;
 
-- 
2.45.2

[COMMITTED 12/13] ada: Fix generic renaming table low bound on reset

[Marc Poulhiès]

From: Ronan Desplanques <desplanques@adacore.com>

gcc/ada/

	* sem_ch12.adb (Save_And_Reset): Fix value of low bound used to
	reset table.

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

---
 gcc/ada/sem_ch12.adb | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index b93e8231c84..127b521e0a5 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -18095,7 +18095,7 @@ package body Sem_Ch12 is
             end loop;
 
             Generic_Renamings.Init;
-            Generic_Renamings.Set_Last (0);
+            Generic_Renamings.Set_Last (-1);
             Generic_Renamings_HTable.Reset;
          end return;
       end Save_And_Reset;
-- 
2.45.2

[COMMITTED 13/13] ada: Use static allocation for small dynamic string concatenations in more cases

[Marc Poulhiès]

From: Eric Botcazou <ebotcazou@adacore.com>

This lifts the limitation of the original implementation whereby the first
operand of the concatenation needs to have a length known at compiled time
in order for the static allocation to be used.

gcc/ada/

	* exp_ch4.adb (Expand_Concatenate): In the case where an operand
	does not have both bounds known at compile time, use nevertheless
	the low bound directly if it is known at compile time.
	Fold the conditional expression giving the low bound of the result
	in the general case if the low bound of all the operands are equal.

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

---
 gcc/ada/exp_ch4.adb | 91 +++++++++++++++++++++++++++++++++------------
 1 file changed, 67 insertions(+), 24 deletions(-)

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index e4c9de474ad..abe76c8767e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2837,13 +2837,32 @@ package body Exp_Ch4 is
             if not Set then
                NN := NN + 1;
 
-               --  Capture operand bounds
+               --  Set low bound of operand and check first the constrained
+               --  case with known bound
 
-               Opnd_Low_Bound (NN) :=
-                 Make_Attribute_Reference (Loc,
-                   Prefix         =>
-                     Duplicate_Subexpr (Opnd, Name_Req => True),
-                   Attribute_Name => Name_First);
+               if Is_Constrained (Opnd_Typ) then
+                  declare
+                     Low_Bound : constant Node_Id
+                       := Type_Low_Bound
+                            (Underlying_Type (Etype (First_Index (Opnd_Typ))));
+
+                  begin
+                     if Compile_Time_Known_Value (Low_Bound) then
+                        Opnd_Low_Bound (NN) := New_Copy_Tree (Low_Bound);
+                        Set := True;
+                     end if;
+                  end;
+               end if;
+
+               --  Otherwise fall back to the general expression
+
+               if not Set then
+                  Opnd_Low_Bound (NN) :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix         =>
+                        Duplicate_Subexpr (Opnd, Name_Req => True),
+                      Attribute_Name => Name_First);
+               end if;
 
                --  Capture last operand bounds if result could be null
 
@@ -3018,6 +3037,8 @@ package body Exp_Ch4 is
       --  take unconditionally whether or not it is null. It's easiest to do
       --  this with a recursive procedure:
 
+      --  We fold the common case where all the low bounds are the same
+
       else
          declare
             function Get_Known_Bound (J : Nat) return Node_Id;
@@ -3033,32 +3054,54 @@ package body Exp_Ch4 is
                   return New_Copy_Tree (Opnd_Low_Bound (J));
 
                else
-                  return
-                    Make_If_Expression (Loc,
-                      Expressions => New_List (
+                  declare
+                     Known_Bound : constant Node_Id := Get_Known_Bound (J + 1);
+                     Comparison  : constant Compare_Result
+                                     := Compile_Time_Compare
+                                          (Opnd_Low_Bound (J),
+                                           Known_Bound,
+                                           Assume_Valid => True);
 
-                        Make_Op_Ne (Loc,
-                          Left_Opnd  =>
-                            New_Occurrence_Of (Var_Length (J), Loc),
-                          Right_Opnd =>
-                            Make_Integer_Literal (Loc, 0)),
+                  begin
+                     if Comparison = EQ then
+                        return Known_Bound;
 
-                        New_Copy_Tree (Opnd_Low_Bound (J)),
-                        Get_Known_Bound (J + 1)));
+                     else
+                        return
+                          Make_If_Expression (Loc,
+                            Expressions => New_List (
+
+                              Make_Op_Ne (Loc,
+                                Left_Opnd  =>
+                                  New_Occurrence_Of (Var_Length (J), Loc),
+                                Right_Opnd =>
+                                  Make_Integer_Literal (Loc, 0)),
+
+                              New_Copy_Tree (Opnd_Low_Bound (J)),
+                              Known_Bound));
+                     end if;
+                  end;
                end if;
             end Get_Known_Bound;
 
+            Known_Bound : constant Node_Id := Get_Known_Bound (1);
+
          begin
-            Ent := Make_Temporary (Loc, 'L');
+            if Nkind (Known_Bound) /= N_If_Expression then
+               Low_Bound := Known_Bound;
 
-            Append_To (Actions,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Ent,
-                Constant_Present    => True,
-                Object_Definition   => New_Occurrence_Of (Ityp, Loc),
-                Expression          => Get_Known_Bound (1)));
+            else
+               Ent := Make_Temporary (Loc, 'L');
 
-            Low_Bound := New_Occurrence_Of (Ent, Loc);
+               Append_To (Actions,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Ent,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Occurrence_Of (Ityp, Loc),
+                   Expression          => Known_Bound));
+
+               Low_Bound := New_Occurrence_Of (Ent, Loc);
+            end if;
          end;
       end if;
 
-- 
2.45.2