[Ada] Plug loophole for built-in-place return with limited_with clause

[Pierre-Marie de Rodat via Gcc-patches]

When the result type of a function requiring built-in-place return is
only visible through a limited_with clause, the compiled needs to wait
for the nonlimited view to be available in order to compute whether
the built-in-place return is needed, and this comprises tagging the
function with the Returns_By_Ref flag.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch6.adb (Build_In_Place_Formal): Also compute Returns_By_Ref
for the function if the extra formals were not built initially.diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -850,11 +850,12 @@ package body Exp_Ch6 is
   --  The return type in the function declaration may have been a limited
   --  view, and the extra formals for the function were not generated at
   --  that point. At the point of call the full view must be available and
-  --  the extra formals can be created.
+  --  the extra formals can be created and Returns_By_Ref computed.
 
   if No (Extra_Formal) then
  Create_Extra_Formals (Func);
  Extra_Formal := Extra_Formals (Func);
+ Compute_Returns_By_Ref (Func);
   end if;
 
   --  We search for a formal with a matching suffix. We can't search

[Ada] Incorrect accessibility check on return of discriminated type

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects an error in the compiler whereby the presence of a
call to a function returning a type with an access discriminant within
an expanded loop condition caused the wrong value to be supplied for the
extra- accessibility-of-result actual, thus causing incorrect checks
within the callee at the point of return.

This change also corrects a problem where spurious "null value not
allowed" warnings were generated for tagged type declarations with an
access discriminant specified as "null."

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_disp.adb (Most_Descendant_Use_Clause): Remove call to
deprecated Is_Internal.
* sem_util.adb (Innermost_Master_Scope_Depth): Use
Find_Enclosing_Scope instead of Nearest_Dynamic_Scope to avoid
cases where relevant scopes get skipped leading to an incorrect
scope depth calculation.diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -508,12 +508,11 @@ package body Sem_Disp is
  return Empty;
 
   --  The dispatching type and the primitive operation must be defined in
-  --  the same scope, except in the case of internal operations and formal
-  --  abstract subprograms.
+  --  the same scope, except in the case of abstract formal subprograms.
 
-  elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
-   and then (not Is_Generic_Type (Tagged_Type)
-  or else not Comes_From_Source (Subp)))
+  elsif (Scope (Subp) = Scope (Tagged_Type)
+  and then (not Is_Generic_Type (Tagged_Type)
+ or else not Comes_From_Source (Subp)))
 or else
   (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
 or else


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -275,9 +275,9 @@ package body Sem_Util is
   --  with its type set to Natural.
 
   function Innermost_Master_Scope_Depth (N : Node_Id) return Uint;
-  --  Returns the scope depth of the given node's innermost
-  --  enclosing dynamic scope (effectively the accessibility
-  --  level of the innermost enclosing master).
+  --  Returns the scope depth of the given node's innermost enclosing
+  --  scope (effectively the accessibility level of the innermost
+  --  enclosing master).
 
   function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id;
   --  Centralized processing of subprogram calls which may appear in
@@ -301,7 +301,7 @@ package body Sem_Util is
   begin
  --  Locate the nearest enclosing node (by traversing Parents)
  --  that Defining_Entity can be applied to, and return the
- --  depth of that entity's nearest enclosing dynamic scope.
+ --  depth of that entity's nearest enclosing scope.
 
  --  The rules that define what a master are defined in
  --  RM 7.6.1 (3), and include statements and conditions for loops
@@ -311,13 +311,13 @@ package body Sem_Util is
 Ent := Defining_Entity_Or_Empty (Node_Par);
 
 if Present (Ent) then
-   Encl_Scop := Nearest_Dynamic_Scope (Ent);
+   Encl_Scop := Find_Enclosing_Scope (Ent);
 
--  Ignore transient scopes made during expansion
 
if Comes_From_Source (Node_Par) then
   return
-Scope_Depth_Default_0 (Encl_Scop) + Master_Lvl_Modifier;
+Scope_Depth (Encl_Scop) + Master_Lvl_Modifier;
end if;
 
 --  For a return statement within a function, return

[Ada] Adjust description of Pure_Function pragma

[Pierre-Marie de Rodat via Gcc-patches]

The current wording can be read as implying that the result of a call
to a pure function does not depend on the context, which is incorrect.
The pragma only guarantees the absence of side effects of such a call.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* doc/gnat_rm/implementation_defined_pragmas.rst (Pure_Function):
Fix ambiguous wording about context dependence.
* gnat_rm.texi: Regenerate.diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -5504,9 +5504,9 @@ overloaded declaration exists, in which case the pragma applies
 to all entities).  It specifies that the function ``Entity`` is
 to be considered pure for the purposes of code generation.  This means
 that the compiler can assume that there are no side effects, and
-in particular that two calls with identical arguments produce the
-same result.  It also means that the function can be used in an
-address clause.
+in particular that two identical calls produce the same result in
+the same context. It also means that the function can be used in
+an address clause.
 
 Note that, quite deliberately, there are no static checks to try
 to ensure that this promise is met, so ``Pure_Function`` can be used


diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -21,7 +21,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , May 24, 2022
+GNAT Reference Manual , Jun 24, 2022
 
 AdaCore
 
@@ -7088,9 +7088,9 @@ overloaded declaration exists, in which case the pragma applies
 to all entities).  It specifies that the function @code{Entity} is
 to be considered pure for the purposes of code generation.  This means
 that the compiler can assume that there are no side effects, and
-in particular that two calls with identical arguments produce the
-same result.  It also means that the function can be used in an
-address clause.
+in particular that two identical calls produce the same result in
+the same context. It also means that the function can be used in
+an address clause.
 
 Note that, quite deliberately, there are no static checks to try
 to ensure that this promise is met, so @code{Pure_Function} can be used

[Ada] Fix for resolution of overloaded subprogram for Iterable aspect

[Pierre-Marie de Rodat via Gcc-patches]

When resolving the Iterable aspect we look for a functions that are
declared in the same scope as the annotated type and that have the
required number and types formal parameters. However, we didn't guard
against functions that have no formal parameter at all.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch13.adb (Resolve_Iterable_Operation): Add guard to
prevent crash when the examined function has no formal
parameters and Etype is called on Empty entity.diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -15943,6 +15943,7 @@ package body Sem_Ch13 is
 while Present (It.Typ) loop
if Ekind (It.Nam) = E_Function
   and then Scope (It.Nam) = Scope (Typ)
+  and then Present (First_Formal (It.Nam))
   and then Etype (First_Formal (It.Nam)) = Typ
then
   F1 := First_Formal (It.Nam);

[Ada] Update the documentation of functional containers

[Pierre-Marie de Rodat via Gcc-patches]

Functional containers are now controlled. Update the documentation
accordingly.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* doc/gnat_rm/the_gnat_library.rst: Functional vectors, sets,
and maps are now controlled.
* gnat_rm.texi: Regenerate.diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
--- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst
+++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
@@ -285,17 +285,16 @@ specification of this unit is compatible with SPARK 2014.
 .. index:: Functional sets
 
 This child of ``Ada.Containers`` defines immutable sets. These containers are
-unbounded and may contain indefinite elements. Furthermore, to be usable in
-every context, they are neither controlled nor limited. As they are functional,
-that is, no primitives are provided which would allow modifying an existing
-container, these containers can still be used safely.
+unbounded and may contain indefinite elements. Their API features functions
+creating new containers from existing ones. To remain reasonably efficient,
+their implementation involves sharing between data-structures. As they are
+functional, that is, no primitives are provided which would allow modifying an
+existing container, these containers can still be used safely.
 
-Their API features functions creating new containers from existing ones.
-As a consequence, these containers are highly inefficient. They are also
-memory consuming, as the allocated memory is not reclaimed when the container
-is no longer referenced. Thus, they should in general be used in ghost code
-and annotations, so that they can be removed from the final executable. The
-specification of this unit is compatible with SPARK 2014.
+These containers are controlled so that the allocated memory can be reclaimed
+when the container is no longer referenced. Thus, they cannot directly be used
+in contexts where controlled types are not supported.
+The specification of this unit is compatible with SPARK 2014.
 
 .. _`Ada.Containers.Functional_Maps_(a-cofuma.ads)`:
 
@@ -307,17 +306,16 @@ specification of this unit is compatible with SPARK 2014.
 .. index:: Functional maps
 
 This child of ``Ada.Containers`` defines immutable maps. These containers are
-unbounded and may contain indefinite elements. Furthermore, to be usable in
-every context, they are neither controlled nor limited. As they are functional,
-that is, no primitives are provided which would allow modifying an existing
-container, these containers can still be used safely.
-
-Their API features functions creating new containers from existing ones.
-As a consequence, these containers are highly inefficient. They are also
-memory consuming, as the allocated memory is not reclaimed when the container
-is no longer referenced. Thus, they should in general be used in ghost code
-and annotations, so that they can be removed from the final executable. The
-specification of this unit is compatible with SPARK 2014.
+unbounded and may contain indefinite elements. Their API features functions
+creating new containers from existing ones. To remain reasonably efficient,
+their implementation involves sharing between data-structures. As they are
+functional, that is, no primitives are provided which would allow modifying an
+existing container, these containers can still be used safely.
+
+These containers are controlled so that the allocated memory can be reclaimed
+when the container is no longer referenced. Thus, they cannot directly be used
+in contexts where controlled types are not supported.
+The specification of this unit is compatible with SPARK 2014.
 
 .. _`Ada.Containers.Bounded_Holders_(a-coboho.ads)`:
 


diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -23520,17 +23520,16 @@ specification of this unit is compatible with SPARK 2014.
 @geindex Functional sets
 
 This child of @code{Ada.Containers} defines immutable sets. These containers are
-unbounded and may contain indefinite elements. Furthermore, to be usable in
-every context, they are neither controlled nor limited. As they are functional,
-that is, no primitives are provided which would allow modifying an existing
-container, these containers can still be used safely.
+unbounded and may contain indefinite elements. Their API features functions
+creating new containers from existing ones. To remain reasonably efficient,
+their implementation involves sharing between data-structures. As they are
+functional, that is, no primitives are provided which would allow modifying an
+existing container, these containers can still be used safely.
 
-Their API features functions creating new containers from existing ones.
-As a consequence, these containers are highly inefficient. They are also
-memory consuming, as the allocated memory is not reclaimed when the container
-is no longer referenced. Thus, they should in general be used

[Ada] Create new unbounded functional sequence

[Pierre-Marie de Rodat via Gcc-patches]

Add a new unbounded functional sequence. This sequence is indexed by
Big_Positive and so is unbounded from the user and spark points view.
Hower the actually implemented sequence are bounded by Count_Type'Last.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/a-cfinse.adb, libgnat/a-cfinse.ads: Implementation
files of the sequence.
* Makefile.rtl, impunit.adb: Take into account the add of the
new filesdiff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -114,6 +114,7 @@ GNATRTL_NONTASKING_OBJS= \
   a-cfhama$(objext) \
   a-cfhase$(objext) \
   a-cfinve$(objext) \
+  a-cfinse$(objext) \
   a-cforma$(objext) \
   a-cforse$(objext) \
   a-cgaaso$(objext) \


diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -605,6 +605,7 @@ package body Impunit is
-- GNAT Defined Additions to Ada 2012 --

 
+("a-cfinse", F),  -- Ada.Containers.Functional_Infinite_Sequences
 ("a-cfinve", F),  -- Ada.Containers.Formal_Indefinite_Vectors
 ("a-coboho", F),  -- Ada.Containers.Bounded_Holders
 ("a-cofove", F),  -- Ada.Containers.Formal_Vectors


diff --git /dev/null b/gcc/ada/libgnat/a-cfinse.adb
new file mode 100644
--- /dev/null
+++ b/gcc/ada/libgnat/a-cfinse.adb
@@ -0,0 +1,304 @@
+--
+--  --
+-- GNAT LIBRARY COMPONENTS  --
+--  --
+--ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE   --
+--  --
+-- B o d y  --
+--  --
+--  Copyright (C) 2022-2022, Free Software Foundation, Inc. --
+--  --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--  --
+-- 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--
+-- .  --
+--
+
+pragma Ada_2012;
+
+package body Ada.Containers.Functional_Infinite_Sequences
+with SPARK_Mode => Off
+is
+   use Containers;
+
+   ---
+   -- Local Subprograms --
+   ---
+
+   package Big_From_Count is new Signed_Conversions
+ (Int => Count_Type);
+
+   function Big (C : Count_Type) return Big_Integer renames
+ Big_From_Count.To_Big_Integer;
+
+   --  Store Count_Type'Last as a Big Natural because it is often used
+
+   Count_Type_Big_Last : constant Big_Natural := Big (Count_Type'Last);
+
+   function To_Count (C : Big_Natural) return Count_Type;
+   --  Convert Big_Natural to Count_Type
+
+   -
+   -- "<" --
+   -
+
+   function "<" (Left : Sequence; Right : Sequence) return Boolean is
+ (Length (Left) < Length (Right)
+  and then (for all N in Left =>
+ Get (Left, N) = Get (Right, N)));
+
+   --
+   -- "<=" --
+   --
+
+   function "<=" (Left : Sequence; Right : Sequence) return Boolean is
+ (Length (Left) <= Length (Right)
+  and then (for all N in Left =>
+ Get (Left, N) = Get (Right, N)));
+
+   -
+   -- "=" --

[Ada] Tech debt: Remove code duplication

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects removes some code duplication within the GNAT
compiler.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_util.adb (Remove_Side_Effects): Combine identical
branches.
* sem_attr.adb (Analyze_Attribute): Combine identical cases
Attribute_Has_Same_Storage and Attribute_Overlaps_Storage.
* sem_prag.adb (Check_Role): Combine E_Out_Parameter case with
general case for parameters.
* sem_util.adb (Accessibility_Level): Combine identical
branches.
* sprint.adb (Sprint_Node_Actual): Combine cases for
N_Real_Range_Specification and N_Signed_Integer_Type_Definition.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -12017,31 +12017,23 @@ package body Exp_Util is
   --  renaming is handled by the front end, as the back end may balk at
   --  the nonstandard representation (see Evaluation_Required in Exp_Ch8).
 
-  elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
-and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
-  then
- Def_Id := Build_Temporary (Loc, 'R', Exp);
- Res := New_Occurrence_Of (Def_Id, Loc);
-
- Insert_Action (Exp,
-   Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Mark=> New_Occurrence_Of (Exp_Type, Loc),
- Name=> Relocate_Node (Exp)));
+  elsif (Nkind (Exp) in N_Indexed_Component | N_Selected_Component
+  and then Has_Non_Standard_Rep (Etype (Prefix (Exp
 
-  --  For an expression that denotes a name, we can use a renaming scheme.
-  --  This is needed for correctness in the case of a volatile object of
-  --  a nonvolatile type because the Make_Reference call of the "default"
-  --  approach would generate an illegal access value (an access value
-  --  cannot designate such an object - see Analyze_Reference).
+--  For an expression that denotes a name, we can use a renaming
+--  scheme. This is needed for correctness in the case of a volatile
+--  object of a nonvolatile type because the Make_Reference call of the
+--  "default" approach would generate an illegal access value (an
+--  access value cannot designate such an object - see
+--  Analyze_Reference).
 
-  elsif Is_Name_Reference (Exp)
+or else (Is_Name_Reference (Exp)
 
---  We skip using this scheme if we have an object of a volatile
---  type and we do not have Name_Req set true (see comments for
---  Side_Effect_Free).
+  --  We skip using this scheme if we have an object of a volatile
+  --  type and we do not have Name_Req set true (see comments for
+  --  Side_Effect_Free).
 
-and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
+  and then (Name_Req or else not Treat_As_Volatile (Exp_Type)))
   then
  Def_Id := Build_Temporary (Loc, 'R', Exp);
  Res := New_Occurrence_Of (Def_Id, Loc);


diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4451,7 +4451,9 @@ package body Sem_Attr is
   -- Has_Same_Storage --
   --
 
-  when Attribute_Has_Same_Storage =>
+  when Attribute_Has_Same_Storage
+ | Attribute_Overlaps_Storage
+  =>
  Check_E1;
 
  --  The arguments must be objects of any type
@@ -5563,21 +5565,6 @@ package body Sem_Attr is
  end if;
   end Old;
 
-  --
-  -- Overlaps_Storage --
-  --
-
-  when Attribute_Overlaps_Storage =>
- Check_E1;
-
- --  Both arguments must be objects of any type
-
- Analyze_And_Resolve (P);
- Analyze_And_Resolve (E1);
- Check_Object_Reference (P);
- Check_Object_Reference (E1);
- Set_Etype (N, Standard_Boolean);
-
   
   -- Output --
   


diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -1361,36 +1361,15 @@ package body Sem_Prag is
 
when E_Generic_In_Out_Parameter
   | E_In_Out_Parameter
+  | E_Out_Parameter
   | E_Variable
=>
-  --  When pragma Global is present it determines the mode of
-  --  the object.
-
-  if Global_Seen then
-
- --  A variable has mode IN when its type is unconstrained
- --  or tagged because array bounds, discriminants or tags
- --  can be read.
-
- Item_Is_Input :=
-   Appears_In (Subp_Inputs, Item_Id)
- or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
-

[Ada] Compiler rejects legal allocator in record component constraint expression

[Pierre-Marie de Rodat via Gcc-patches]

In some cases when a legal allocator which defines a new subtype for the
allocated object occurs as part of a record component constraint
expression, the compiler would incorrectly reject the allocator.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch4.adb (Analyze_Allocator): After calling Insert_Action
to insert a subtype declaration associated with an allocator,
the subtype declaration will usually be analyzed. But not
always. Add an explicit call to Preanalyze to cope with the
unusual case. The subtype declaration must be at least
preanalyzed before the call to Sem_Ch3.Process_Subtype a little
while later, during which we analyze an identifier that refers
to the subtype.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -670,10 +670,19 @@ package body Sem_Ch4 is
then
   Def_Id := Make_Temporary (Loc, 'S');
 
-  Insert_Action (E,
-Make_Subtype_Declaration (Loc,
-  Defining_Identifier => Def_Id,
-  Subtype_Indication  => Relocate_Node (E)));
+  declare
+ Subtype_Decl : constant Node_Id :=
+   Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication  => Relocate_Node (E));
+  begin
+ Insert_Action (E, Subtype_Decl);
+
+ --  Handle unusual case where Insert_Action does not
+ --  analyze the declaration. Subtype_Decl must be
+ --  preanalyzed before call to Process_Subtype below.
+ Preanalyze (Subtype_Decl);
+  end;
 
   if Sav_Errs /= Serious_Errors_Detected
 and then Nkind (Constraint (E)) =

[Ada] Add Ada 2022 features to sets containers

[Pierre-Marie de Rodat via Gcc-patches]

This patch adds some Ada 2022 features to the set children of
Ada.Containers.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/a-cbhase.adb, libgnat/a-cbhase.ads,
libgnat/a-cborse.adb, libgnat/a-cborse.ads,
libgnat/a-cihase.adb, libgnat/a-cihase.ads,
libgnat/a-ciorse.adb, libgnat/a-ciorse.ads,
libgnat/a-cohase.adb, libgnat/a-cohase.ads,
libgnat/a-conhel.adb, libgnat/a-conhel.ads,
libgnat/a-coorse.adb, libgnat/a-coorse.ads: Add Has_Element,
Element, Query_Element, and Next subprograms that take a Set
parameter. Add Tampering_With_Cursors_Prohibited function. These
are all new in Ada 2022.diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
--- a/gcc/ada/libgnat/a-cbhase.adb
+++ b/gcc/ada/libgnat/a-cbhase.adb
@@ -1599,6 +1599,64 @@ is
   raise Program_Error with "attempt to stream reference";
end Write;
 
+   --  Ada 2022 features:
+
+   function Has_Element (Container : Set; Position : Cursor) return Boolean is
+   begin
+  pragma Assert (Vet (Position), "bad cursor in Has_Element");
+  pragma Assert ((Position.Container = null) = (Position.Node = 0),
+ "bad nullity in Has_Element");
+  return Position.Container = Container'Unrestricted_Access;
+   end Has_Element;
+
+   function Tampering_With_Cursors_Prohibited
+ (Container : Set) return Boolean
+   is
+   begin
+  return Is_Busy (Container.TC);
+   end Tampering_With_Cursors_Prohibited;
+
+   function Element (Container : Set; Position : Cursor) return Element_Type is
+   begin
+  if Checks and then not Has_Element (Container, Position) then
+ raise Program_Error with "Position for wrong Container";
+  end if;
+
+  return Element (Position);
+   end Element;
+
+   procedure Query_Element
+ (Container : Set;
+  Position  : Cursor;
+  Process   : not null access procedure (Element : Element_Type)) is
+   begin
+  if Checks and then not Has_Element (Container, Position) then
+ raise Program_Error with "Position for wrong Container";
+  end if;
+
+  Query_Element (Position, Process);
+   end Query_Element;
+
+   function Next (Container : Set; Position : Cursor) return Cursor is
+   begin
+  if Checks and then
+not (Position = No_Element or else Has_Element (Container, Position))
+  then
+ raise Program_Error with "Position for wrong Container";
+  end if;
+
+  return Next (Position);
+   end Next;
+
+   procedure Next (Container : Set; Position : in out Cursor) is
+   begin
+  Position := Next (Container, Position);
+   end Next;
+
+   --
+   -- Generic_Keys --
+   --
+
package body Generic_Keys is
 
   ---


diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads
--- a/gcc/ada/libgnat/a-cbhase.ads
+++ b/gcc/ada/libgnat/a-cbhase.ads
@@ -369,6 +369,25 @@ is
  (Container : Set)
   return Set_Iterator_Interfaces.Forward_Iterator'Class;
 
+   --  Ada 2022 features:
+
+   function Has_Element (Container : Set; Position : Cursor) return Boolean;
+
+   function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean;
+
+   function Element (Container : Set; Position : Cursor) return Element_Type;
+
+   procedure Query_Element
+ (Container : Set;
+  Position  : Cursor;
+  Process   : not null access procedure (Element : Element_Type));
+
+   function Next (Container : Set; Position : Cursor) return Cursor;
+
+   procedure Next (Container : Set; Position : in out Cursor);
+
+   
+
generic
   type Key_Type (<>) is private;
 


diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -688,6 +688,62 @@ is
   else Cursor'(Container'Unrestricted_Access, Node));
end Floor;
 
+   --  Ada 2022 features:
+
+   function Has_Element (Container : Set; Position : Cursor) return Boolean is
+   begin
+  pragma Assert
+(Position.Container = null or else Vet (Container, Position.Node),
+ "bad cursor in Has_Element");
+  pragma Assert ((Position.Container = null) = (Position.Node = 0),
+ "bad nullity in Has_Element");
+  return Position.Container = Container'Unrestricted_Access;
+   end Has_Element;
+
+   function Tampering_With_Cursors_Prohibited
+ (Container : Set) return Boolean
+   is
+   begin
+  return Is_Busy (Container.TC);
+   end Tampering_With_Cursors_Prohibited;
+
+   function Element (Container : Set; Position : Cursor) return Element_Type is
+   begin
+  if Checks and then not Has_Element (Container, Position) then
+ raise Program_Error with "Position for wrong Container";
+  end if;
+
+  return Element (Position);
+   end Element;
+
+   procedure Query_Element
+ (Container : Set;
+  Position  : Curso

[Ada] Assertions in Einfo.Utils

[Pierre-Marie de Rodat via Gcc-patches]

Add predicates on subtypes E and N.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* einfo-utils.ads, einfo-utils.adb: Add predicates on subtypes E
and N.  Change some parameters to use the unpredicated subtypes,
because they sometimes return e.g. Empty.  Note that N_Entity_Id
has a predicate; Entity_Id does not.
* exp_tss.adb (Base_Init_Proc): Use Entity_Id instead of E,
because otherwise we fail the predicate. We shouldn't be
referring to single-letter names from far away anyway.
* sem_aux.adb (Is_Derived_Type): Likewise.
* sem_res.adb (Is_Definite_Access_Type): Use N_Entity_Id for
predicate.
* types.ads (Entity_Id): Add comment explaining the difference
between Entity_Id and N_Entity_Id.diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -28,7 +28,6 @@ with Elists; use Elists;
 with Nlists; use Nlists;
 with Output; use Output;
 with Sinfo;  use Sinfo;
-with Sinfo.Nodes;use Sinfo.Nodes;
 with Sinfo.Utils;use Sinfo.Utils;
 
 package body Einfo.Utils is
@@ -307,7 +306,7 @@ package body Einfo.Utils is
   return Ekind (Id) in Generic_Unit_Kind;
end Is_Generic_Unit;
 
-   function Is_Ghost_Entity (Id : Entity_Id) return Boolean is
+   function Is_Ghost_Entity (Id : E) return Boolean is
begin
   return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id);
end Is_Ghost_Entity;
@@ -593,7 +592,7 @@ package body Einfo.Utils is
-- Address_Clause --

 
-   function Address_Clause (Id : E) return N is
+   function Address_Clause (Id : E) return Node_Id is
begin
   return Get_Attribute_Definition_Clause (Id, Attribute_Address);
end Address_Clause;
@@ -618,7 +617,7 @@ package body Einfo.Utils is
-- Alignment_Clause --
--
 
-   function Alignment_Clause (Id : E) return N is
+   function Alignment_Clause (Id : E) return Node_Id is
begin
   return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
end Alignment_Clause;
@@ -672,7 +671,7 @@ package body Einfo.Utils is
-- Declaration_Node --
--
 
-   function Declaration_Node (Id : E) return N is
+   function Declaration_Node (Id : E) return Node_Id is
   P : Node_Id;
 
begin
@@ -771,7 +770,7 @@ package body Einfo.Utils is
-- First_Component --
-
 
-   function First_Component (Id : E) return E is
+   function First_Component (Id : E) return Entity_Id is
   Comp_Id : Entity_Id;
 
begin
@@ -793,7 +792,7 @@ package body Einfo.Utils is
-- First_Component_Or_Discriminant --
-
 
-   function First_Component_Or_Discriminant (Id : E) return E is
+   function First_Component_Or_Discriminant (Id : E) return Entity_Id is
   Comp_Id : Entity_Id;
 
begin
@@ -816,7 +815,7 @@ package body Einfo.Utils is
-- First_Formal --
--
 
-   function First_Formal (Id : E) return E is
+   function First_Formal (Id : E) return Entity_Id is
   Formal : Entity_Id;
 
begin
@@ -857,7 +856,7 @@ package body Einfo.Utils is
-- First_Formal_With_Extras --
--
 
-   function First_Formal_With_Extras (Id : E) return E is
+   function First_Formal_With_Extras (Id : E) return Entity_Id is
   Formal : Entity_Id;
 
begin
@@ -1383,7 +1382,7 @@ package body Einfo.Utils is
-- Invariant_Procedure --
-
 
-   function Invariant_Procedure (Id : E) return E is
+   function Invariant_Procedure (Id : E) return Entity_Id is
   Subp_Elmt : Elmt_Id;
   Subp_Id   : Entity_Id;
   Subps : Elist_Id;
@@ -1525,7 +1524,7 @@ package body Einfo.Utils is
-- Is_Elaboration_Target --
---
 
-   function Is_Elaboration_Target (Id : Entity_Id) return Boolean is
+   function Is_Elaboration_Target (Id : E) return Boolean is
begin
   return
 Ekind (Id) in E_Constant | E_Package | E_Variable
@@ -1768,7 +1767,7 @@ package body Einfo.Utils is
-- Last_Formal --
-
 
-   function Last_Formal (Id : E) return E is
+   function Last_Formal (Id : E) return Entity_Id is
   Formal : Entity_Id;
 
begin
@@ -1911,7 +1910,7 @@ package body Einfo.Utils is
-- Next_Component --

 
-   function Next_Component (Id : E) return E is
+   function Next_Component (Id : E) return Entity_Id is
   Comp_Id : Entity_Id;
 
begin
@@ -1928,7 +1927,7 @@ package body Einfo.Utils is
-- Next_Component_Or_Discriminant --

 
-   function Next_Component_Or_Discriminant (Id : E) return E is
+   function Next_Component_Or_Discriminant (Id : E) return Entity_Id is
   Comp_Id : Entity_Id;
 
begin
@@ -1949,7 +1948,7 @@ pack

[Ada] Add GNAT specific pragmas to the equivalent Assertion_Policy for -gnata

[Pierre-Marie de Rodat via Gcc-patches]

All assertion pragmas are enabled by default when using -gnata. We need
to add the GNAT specific ones to the list.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* doc/gnat_ugn/building_executable_programs_with_gnat.rst
(Debugging and Assertion Control): Add GNAT specific assertion
pragmas to the equivalent Assertion_Policy for the -gnata
option.
* gnat_ugn.texi: Regenerate.diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -4331,15 +4331,31 @@ Debugging and Assertion Control
   Which is a shorthand for::
 
pragma Assertion_Policy
- (Assert   => Check,
-  Static_Predicate => Check,
-  Dynamic_Predicate=> Check,
-  Pre  => Check,
-  Pre'Class=> Check,
-  Post => Check,
-  Post'Class   => Check,
-  Type_Invariant   => Check,
-  Type_Invariant'Class => Check);
+   --  Ada RM assertion pragmas
+ (Assert=> Check,
+  Static_Predicate  => Check,
+  Dynamic_Predicate => Check,
+  Pre   => Check,
+  Pre'Class => Check,
+  Post  => Check,
+  Post'Class=> Check,
+  Type_Invariant=> Check,
+  Type_Invariant'Class  => Check,
+  Default_Initial_Condition => Check,
+   --  GNAT specific assertion pragmas
+  Assert_And_Cut=> Check,
+  Assume=> Check,
+  Contract_Cases=> Check,
+  Debug => Check,
+  Ghost => Check,
+  Initial_Condition => Check,
+  Loop_Invariant=> Check,
+  Loop_Variant  => Check,
+  Postcondition => Check,
+  Precondition  => Check,
+  Predicate => Check,
+  Refined_Post  => Check,
+  Subprogram_Variant=> Check);
 
   The pragmas ``Assert`` and ``Debug`` normally have no effect and
   are ignored. This switch, where ``a`` stands for 'assert', causes


diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,7 +21,7 @@
 
 @copying
 @quotation
-GNAT User's Guide for Native Platforms , May 24, 2022
+GNAT User's Guide for Native Platforms , Jun 24, 2022
 
 AdaCore
 
@@ -12853,15 +12853,31 @@ Which is a shorthand for:
 
 @example
 pragma Assertion_Policy
-  (Assert   => Check,
-   Static_Predicate => Check,
-   Dynamic_Predicate=> Check,
-   Pre  => Check,
-   Pre'Class=> Check,
-   Post => Check,
-   Post'Class   => Check,
-   Type_Invariant   => Check,
-   Type_Invariant'Class => Check);
+--  Ada RM assertion pragmas
+  (Assert=> Check,
+   Static_Predicate  => Check,
+   Dynamic_Predicate => Check,
+   Pre   => Check,
+   Pre'Class => Check,
+   Post  => Check,
+   Post'Class=> Check,
+   Type_Invariant=> Check,
+   Type_Invariant'Class  => Check,
+   Default_Initial_Condition => Check,
+--  GNAT specific assertion pragmas
+   Assert_And_Cut=> Check,
+   Assume=> Check,
+   Contract_Cases=> Check,
+   Debug => Check,
+   Ghost => Check,
+   Initial_Condition => Check,
+   Loop_Invariant=> Check,
+   Loop_Variant  => Check,
+   Postcondition => Check,
+   Precondition  => Check,
+   Predicate => Check,
+   Refined_Post  => Check,
+   Subprogram_Variant=> Check);
 @end example
 
 The pragmas @code{Assert} and @code{Debug} normally have no effect and
@@ -29249,8 +29265,8 @@ to permit their use in free software.
 
 @printindex ge
 
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{  }
 @anchor{cf}@w{  }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{  }
 
 @c %**end of body
 @bye

[Ada] Single character argument in call to Quote_Argument raises error

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects an issue in the compiler whereby calling
Quote_Argument with an argument that is of size 1 may lead to a
CONSTRAINT_ERROR raised at runtime due to an undersized buffer.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/s-os_lib.adb (Quote_Argument): Modify the result
buffer size calculation to handle the case where Arg'Length is
1.diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb
--- a/gcc/ada/libgnat/s-os_lib.adb
+++ b/gcc/ada/libgnat/s-os_lib.adb
@@ -1940,7 +1940,7 @@ package body System.OS_Lib is
   procedure Quote_Argument (Arg : in out String_Access) is
  J: Positive := 1;
  Quote_Needed : Boolean  := False;
- Res  : String (1 .. Arg'Length * 2);
+ Res  : String (1 .. Arg'Length * 2 + 2);
 
   begin
  if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then

[Ada] Do not use front-end build-in-place mechanism for nonlimited types

[Pierre-Marie de Rodat via Gcc-patches]

It was only used in specific cases for controlled types but no longer
provides any significant benefit in practice.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* debug.adb (d.9): Remove usage.
* exp_ch6.adb (Expand_Simple_Function_Return): Remove redundant
test on Debug_Flag_Dot_L.
(Is_Build_In_Place_Result_Type): Return false for nonlimited types.
(Is_Build_In_Place_Function): Tidy up and remove redundant test on
Debug_Flag_Dot_L.diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -211,7 +211,7 @@ package body Debug is
--  d.6  Do not avoid declaring unreferenced types in C code
--  d.7  Disable unsound heuristics in gnat2scil (for CP as SPARK prover)
--  d.8  Disable unconditional inlining of expression functions
-   --  d.9  Disable build-in-place for nonlimited types
+   --  d.9
 
--  d_1
--  d_2
@@ -1125,9 +1125,6 @@ package body Debug is
--   This debug flag turns off this behavior, making them subject
--   to the usual inlining heuristics of the code generator.
 
-   --  d.9  Disable build-in-place for function calls returning nonlimited
-   --   types.
-
--
-- Documentation for Binder Debug Flags --
--


diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -7252,7 +7252,6 @@ package body Exp_Ch6 is
 
   if not Comes_From_Extended_Return_Statement (N)
 and then Is_Build_In_Place_Function (Scope_Id)
-and then not Debug_Flag_Dot_L
 
  --  The functionality of interface thunks is simple and it is always
  --  handled by means of simple return statements. This leaves their
@@ -8534,72 +8533,9 @@ package body Exp_Ch6 is
   --  of a function with a limited interface result, where the function
   --  may return objects of nonlimited descendants.
 
-  if Is_Limited_View (Typ) then
- return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
-
-  else
- if Debug_Flag_Dot_9 then
-return False;
- end if;
-
- if Has_Interfaces (Typ) then
-return False;
- end if;
-
- declare
-T : Entity_Id := Typ;
- begin
---  For T'Class, return True if it's True for T. This is necessary
---  because a class-wide function might say "return F (...)", where
---  F returns the corresponding specific type. We need a loop in
---  case T is a subtype of a class-wide type.
-
-while Is_Class_Wide_Type (T) loop
-   T := Etype (T);
-end loop;
-
---  If this is a generic formal type in an instance, return True if
---  it's True for the generic actual type.
-
-if Nkind (Parent (T)) = N_Subtype_Declaration
-  and then Present (Generic_Parent_Type (Parent (T)))
-then
-   T := Entity (Subtype_Indication (Parent (T)));
-
-   if Present (Full_View (T)) then
-  T := Full_View (T);
-   end if;
-end if;
-
-if Present (Underlying_Type (T)) then
-   T := Underlying_Type (T);
-end if;
-
-declare
-   Result : Boolean;
-   --  So we can stop here in the debugger
-begin
-   --  ???For now, enable build-in-place for a very narrow set of
-   --  controlled types. Change "if True" to "if False" to
-   --  experiment with more controlled types. Eventually, we might
-   --  like to enable build-in-place for all tagged types, all
-   --  types that need finalization, and all caller-unknown-size
-   --  types.
-
-   if True then
-  Result := Is_Controlled (T)
-and then not Is_Generic_Actual_Type (T)
-and then Present (Enclosing_Subprogram (T))
-and then not Is_Compilation_Unit (Enclosing_Subprogram (T))
-and then Ekind (Enclosing_Subprogram (T)) = E_Procedure;
-   else
-  Result := Is_Controlled (T);
-   end if;
-
-   return Result;
-end;
- end;
-  end if;
+  return Is_Limited_View (Typ)
+and then Ada_Version >= Ada_2005
+and then not Debug_Flag_Dot_L;
end Is_Build_In_Place_Result_Type;
 
--
@@ -8635,6 +8571,9 @@ package body Exp_Ch6 is

 
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
+  Kind : constant Entity_Kind := Ekind (E);
+  Typ  : constant Entity_Id   := Etype (E);
+
begin
   --  This function is called from Expand_Subtype_From_Expr durin

[Ada] Give missing error on ambiguous operand of equality operator

[Pierre-Marie de Rodat via Gcc-patches]

When the code responsible for giving errors on ambiguous operands of
comparison and equality operators was moved from the 1st phase (analysis)
to the 2nd phase (resolution) of semantic processing, it was incorrectly
restricted to the operator case, which was valid during the 1st phase but
is not during the 2nd phase.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_res.adb (Resolve_Comparison_Op): Deal with ambiguous operands
in all cases.
(Resolve_Equality_Op): Likewise, except for the case of the implicit
inequality operator created for a user-defined operator that is not
an intrinsic subprogram.diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7539,9 +7539,7 @@ package body Sem_Res is
   if T = Any_Type then
  --  Deal with explicit ambiguity of operands
 
- if Ekind (Entity (N)) = E_Operator
-   and then (Is_Overloaded (L) or else Is_Overloaded (R))
- then
+ if Is_Overloaded (L) or else Is_Overloaded (R) then
 Ambiguous_Operands (N);
  end if;
 
@@ -8563,6 +8561,16 @@ package body Sem_Res is
   L : constant Node_Id := Left_Opnd (N);
   R : constant Node_Id := Right_Opnd (N);
 
+  Implicit_NE_For_User_Defined_Operator : constant Boolean :=
+Nkind (N) = N_Op_Ne
+  and then Ekind (Entity (N)) = E_Function
+  and then not Comes_From_Source (Entity (N))
+  and then not
+Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N)));
+  --  Whether this is a call to the implicit inequality operator created
+  --  for a user-defined operator that is not an intrinsic subprogram, in
+  --  which case we need to skip some processing.
+
   T : Entity_Id := Find_Unique_Type (L, R);
 
   procedure Check_Access_Attribute (N : Node_Id);
@@ -8833,9 +8841,12 @@ package body Sem_Res is
   Generate_Reference (T, N, ' ');
 
   if T = Any_Type then
- --  Deal with explicit ambiguity of operands
+ --  Deal with explicit ambiguity of operands, unless this is a call
+ --  to the implicit inequality operator created for a user-defined
+ --  operator that is not an intrinsic subprogram, since the common
+ --  resolution of operands done here does not apply to it.
 
- if Ekind (Entity (N)) = E_Operator
+ if not Implicit_NE_For_User_Defined_Operator
and then (Is_Overloaded (L) or else Is_Overloaded (R))
  then
 Ambiguous_Operands (N);
@@ -9009,17 +9020,11 @@ package body Sem_Res is
  Generate_Operator_Reference (N, T);
  Check_Low_Bound_Tested (N);
 
- --  If this is an inequality, it may be the implicit inequality
- --  created for a user-defined operation, in which case the corres-
- --  ponding equality operation is not intrinsic, and the operation
- --  cannot be constant-folded. Else fold.
+ --  Unless this is a call to the implicit inequality operator created
+ --  for a user-defined operator that is not an intrinsic subprogram,
+ --  try to fold the operation.
 
- if Nkind (N) = N_Op_Eq
-   or else Comes_From_Source (Entity (N))
-   or else Ekind (Entity (N)) = E_Operator
-   or else
- Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N)))
- then
+ if not Implicit_NE_For_User_Defined_Operator then
 Analyze_Dimension (N);
 Eval_Relational_Op (N);
 

[Ada] Refactor duplicated resolution of Count and Index attributes

[Pierre-Marie de Rodat via Gcc-patches]

Attribute Index, which was added to Ada 2022 by AI12-0143, is resolved
just like attribute Count. However, code duplication rightly triggered a
CodePeer warning.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb (Resolve_Attribute): Refactor duplicated code for
Count and Index attributes.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12300,7 +12300,9 @@ package body Sem_Attr is
  --  if it is an element of an entry family, the index itself may
  --  have to be resolved because it can be a general expression.
 
- when Attribute_Count =>
+ when Attribute_Count
+| Attribute_Index
+ =>
 if Nkind (P) = N_Indexed_Component
   and then Is_Entity_Name (Prefix (P))
 then
@@ -12338,19 +12340,7 @@ package body Sem_Attr is
  -- Index --
  ---
 
- when Attribute_Index =>
-if Nkind (P) = N_Indexed_Component
-  and then Is_Entity_Name (Prefix (P))
-then
-   declare
-  Indx : constant Node_Id   := First (Expressions (P));
-  Fam  : constant Entity_Id := Entity (Prefix (P));
-
-   begin
-  Resolve (Indx, Entry_Index_Type (Fam));
-  Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam));
-   end;
-end if;
+ --  Processing is shared with Count
 
  
  -- Loop_Entry --

[Ada] Use static stack allocation for small dynamic string concatenations

[Pierre-Marie de Rodat via Gcc-patches]

This changes the expanded code generated for dynamic concatenations to
use a static array subtype for the temporary created on the stack if a
small upper bound can be computed for the length of the result.  Static
stack allocation is preferred over dynamic allocation for code
generation purposes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Expand_N_Object_Declaration.Rewrite_As_Renaming):
Be prepared for slices.
* exp_ch4.adb (Get_First_Index_Bounds): New procedure.
(Expand_Array_Comparison.Length_Less_Than_4): Call it.
(Expand_Concatenate): Try to compute a maximum length for
operands with variable length and a maximum total length at the
end.  If the concatenation is dynamic, but a sensible maximum
total length has been computed, use this length to create a
static array subtype for the temporary and return a slice of it.diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6806,6 +6806,21 @@ package body Exp_Ch3 is
   -
 
   function Rewrite_As_Renaming return Boolean is
+
+ function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean;
+ --  Return True if N denotes an entity with OK_To_Rename set
+
+ --
+ -- OK_To_Rename_Entity_Name --
+ --
+
+ function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean is
+ begin
+return Is_Entity_Name (N)
+  and then Ekind (Entity (N)) = E_Variable
+  and then OK_To_Rename (Entity (N));
+ end OK_To_Rename_Entity_Name;
+
  Result : constant Boolean :=
 
  --  If the object declaration appears in the form
@@ -6844,10 +6859,11 @@ package body Exp_Ch3 is
 
or else
  (not Aliased_Present (N)
-   and then Is_Entity_Name (Expr_Q)
-   and then Ekind (Entity (Expr_Q)) = E_Variable
-   and then OK_To_Rename (Entity (Expr_Q))
-   and then Is_Entity_Name (Obj_Def));
+   and then (OK_To_Rename_Entity_Name (Expr_Q)
+  or else
+ (Nkind (Expr_Q) = N_Slice
+   and then
+  OK_To_Rename_Entity_Name (Prefix (Expr_Q);
   begin
  --  ??? Return False if there are any aspect specifications, because
  --  otherwise we duplicate that corresponding implicit attribute


diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -174,6 +174,10 @@ package body Exp_Ch4 is
--  routine is to find the real type by looking up the tree. We also
--  determine if the operation must be rounded.
 
+   procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint);
+   --  T is an array whose index bounds are all known at compile time. Return
+   --  the value of the low and high bounds of the first index of T.
+
function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
--  Return the size of a small signed integer type covering Lo .. Hi, the
--  main goal being to return a size lower than that of standard types.
@@ -1328,29 +1332,17 @@ package body Exp_Ch4 is
  if Ekind (Otyp) = E_String_Literal_Subtype then
 return String_Literal_Length (Otyp) < 4;
 
- else
+ elsif Compile_Time_Known_Bounds (Otyp) then
 declare
-   Ityp : constant Entity_Id := Etype (First_Index (Otyp));
-   Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
-   Hi   : constant Node_Id   := Type_High_Bound (Ityp);
-   Lov  : Uint;
-   Hiv  : Uint;
+   Lo, Hi : Uint;
 
 begin
-   if Compile_Time_Known_Value (Lo) then
-  Lov := Expr_Value (Lo);
-   else
-  return False;
-   end if;
-
-   if Compile_Time_Known_Value (Hi) then
-  Hiv := Expr_Value (Hi);
-   else
-  return False;
-   end if;
-
-   return Hiv < Lov + 3;
+   Get_First_Index_Bounds (Otyp, Lo, Hi);
+   return Hi < Lo + 3;
 end;
+
+ else
+return False;
  end if;
   end Length_Less_Than_4;
 
@@ -2701,6 +2693,9 @@ package body Exp_Ch4 is
   --  this loop is complete, always contains the last operand (which is not
   --  the same as Operands (NN), since null operands are skipped).
 
+  Too_Large_Max_Length : constant Unat := UI_From_Int (256);
+  --  Threshold from which the computation of maximum lengths is useless
+
   --  Arrays describing the operands, only the first NN entries of each
   --  array are set (NN < N when we exclude known null operands).
 
@@ -2711,10 +2706,15 @@ 

[Ada] Add a RM entry for the functional infinite sequences

[Pierre-Marie de Rodat via Gcc-patches]

Modify the RM to take into account the new functional container.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* doc/gnat_rm/the_gnat_library.rst: Add the new entry.
* gnat_rm.texi: Regenerate.

patch.diff.gz
Description: application/gzip

[Ada] Fix dispatching call to primitive function with controlling tagged result

[Pierre-Marie de Rodat via Gcc-patches]

When a dispatching call is made to a primitive function with a controlling
tagged result, the call is dispatching on result and thus must return the
class-wide type of the tagged type to accommodate all possible results.

This was ensured by Expand_Dispatching_Call only in the common case where
the result type is the type of the controlling argument, which does not
cover the case of a primitive function inherited from an ancestor type.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_disp.adb (Expand_Dispatching_Call): Fix detection of calls
that are dispatching on tagged result.diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -896,8 +896,14 @@ package body Exp_Disp is
   Copy_Strub_Mode (Subp_Typ, Subp);
   Set_Convention  (Subp_Typ, Convention (Subp));
 
-  if Etype (Subp) = Typ then
- Set_Etype  (Subp_Typ, CW_Typ);
+  --  If this is a function and it has a controlling tagged result, then
+  --  the call is dispatching on result and returns the class-wide type.
+
+  if Ekind (Subp) = E_Function
+and then Has_Controlling_Result (Subp)
+and then Is_Tagged_Type (Etype (Subp))
+  then
+ Set_Etype  (Subp_Typ, Class_Wide_Type (Etype (Subp)));
  Set_Returns_By_Ref (Subp_Typ, True);
   else
  Set_Etype  (Subp_Typ, Etype (Subp));

[Ada] Small housekeeping work in Expand_N_Object_Declaration

[Pierre-Marie de Rodat via Gcc-patches]

The local function Rewrite_As_Renaming can be called twice in certain
circumstances, which is both not quite safe and unnecessary, so this
replaces it with a local variable whose value is computed only once.

No functional changes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Expand_N_Object_Declaration) : New
local function.
: Change to a local variable whose value is
computed once and generate a call to Finalize after this is done.
Simplify the code creating the renaming at the end.diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6173,7 +6173,7 @@ package body Exp_Ch3 is
   Obj_Def  : constant Node_Id:= Object_Definition (N);
   Typ  : constant Entity_Id  := Etype (Def_Id);
   Base_Typ : constant Entity_Id  := Base_Type (Typ);
-  Expr_Q   : Node_Id;
+  Next_N   : constant Node_Id:= Next (N);
 
   function Build_Equivalent_Aggregate return Boolean;
   --  If the object has a constrained discriminated type and no initial
@@ -6193,9 +6193,8 @@ package body Exp_Ch3 is
   --  Generate all default initialization actions for object Def_Id. Any
   --  new code is inserted after node After.
 
-  function Rewrite_As_Renaming return Boolean;
-  --  Indicate whether to rewrite a declaration with initialization into an
-  --  object renaming declaration (see below).
+  function OK_To_Rename_Ref (N : Node_Id) return Boolean;
+  --  Return True if N denotes an entity with OK_To_Rename set
 
   
   -- Build_Equivalent_Aggregate --
@@ -6801,91 +6800,21 @@ package body Exp_Ch3 is
  end if;
   end Default_Initialize_Object;
 
-  -
-  -- Rewrite_As_Renaming --
-  -
-
-  function Rewrite_As_Renaming return Boolean is
-
- function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean;
- --  Return True if N denotes an entity with OK_To_Rename set
-
- --
- -- OK_To_Rename_Entity_Name --
- --
-
- function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean is
- begin
-return Is_Entity_Name (N)
-  and then Ekind (Entity (N)) = E_Variable
-  and then OK_To_Rename (Entity (N));
- end OK_To_Rename_Entity_Name;
-
- Result : constant Boolean :=
-
- --  If the object declaration appears in the form
-
- --Obj : Typ := Func (...);
-
- --  where Typ both needs finalization and is returned on the secondary
- --  stack, the object declaration can be rewritten into a dereference
- --  of the reference to the result built on the secondary stack (see
- --  Expand_Ctrl_Function_Call for this expansion of the call):
-
- --type Axx is access all Typ;
- --Rxx : constant Axx := Func (...)'reference;
- --Obj : Typ renames Rxx.all;
-
- --  This avoids an extra copy and the pair of Adjust/Finalize calls.
-
- (not Is_Library_Level_Entity (Def_Id)
-and then Nkind (Expr_Q) = N_Explicit_Dereference
-and then not Comes_From_Source (Expr_Q)
-and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
-and then Needs_Finalization (Typ)
-and then not Is_Class_Wide_Type (Typ))
-
-   --  If the initializing expression is for a variable with attribute
-   --  OK_To_Rename set, then transform:
-
-   -- Obj : Typ := Expr;
-
-   --  into
-
-   -- Obj : Typ renames Expr;
-
-   --  provided that Obj is not aliased. The aliased case has to be
-   --  excluded in general because Expr will not be aliased in general.
+  --
+  -- OK_To_Rename_Ref --
+  --
 
-   or else
- (not Aliased_Present (N)
-   and then (OK_To_Rename_Entity_Name (Expr_Q)
-  or else
- (Nkind (Expr_Q) = N_Slice
-   and then
-  OK_To_Rename_Entity_Name (Prefix (Expr_Q);
+  function OK_To_Rename_Ref (N : Node_Id) return Boolean is
   begin
- return Result
-
-   --  The declaration cannot be rewritten if it has got constraints,
-   --  in other words the nominal subtype must be unconstrained.
-
-   and then Is_Entity_Name (Original_Node (Obj_Def))
-
-   --  ??? Return False if there are any aspect specifications, because
-   --  otherwise we duplicate that corresponding implicit attribute
-   --  definition, and call Insert_Action, which has no place to insert
-   --  the attribute definition. The attribute definition is stored in
-   --  Aspect_Rep

[Ada] Avoid unwanted warnings for statically-known-successful assertions

[Pierre-Marie de Rodat via Gcc-patches]

The -gnatwc switch enables warnings for test condition outcomes that are
known at compile time. Such warnings are unlikely to be useful in the
case of an assertion expression (or a subexpression thereof), so do not
generate them in that case.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_warn.adb (Warn_On_Constant_Valid_Condition): Do not
generate a warning if the expression in question is an assertion
expression, or a subexpression thereof. But do call
Test_Comparison so that it can generate warnings for the cases
that it generates warnings for.
* sem_prag.ads: Modify Assertion_Expression_Pragma constant so
that the predicate Sem_Util.In_Assertion_Expression_Pragma
returns True for the expression of a Compile_Time_Error pragma.diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -135,6 +135,7 @@ package Sem_Prag is
   Pragma_Assert_And_Cut=> True,
   Pragma_Assume=> True,
   Pragma_Check => True,
+  Pragma_Compile_Time_Error=> True,
   Pragma_Contract_Cases=> True,
   Pragma_Default_Initial_Condition => True,
   Pragma_Initial_Condition => True,


diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -3401,9 +3401,14 @@ package body Sem_Warn is
 False_Result => False_Result);
 
  --  Warn on a possible evaluation to False / True in the presence of
- --  invalid values.
+ --  invalid values. But issue no warning for an assertion expression
+ --  (or a subexpression thereof); in particular, we don't want a
+ --  warning about an assertion that will always succeed.
 
- if True_Result then
+ if In_Assertion_Expression_Pragma (Op) then
+null;
+
+ elsif True_Result then
 Error_Msg_N
   ("condition can only be False if invalid values present?c?", Op);
 

[Ada] vx7r2: do not include s-qnx.ads in the kernel and rtp runtimes

[Pierre-Marie de Rodat via Gcc-patches]

Target specific runtime files must be added to a the exclude list so the
files don't automatically get copied to other runtimes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* Makefile.rtl (ADA_EXCLUDE_SRCS): Add s-qnx.ads.diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -2937,6 +2937,7 @@ ADA_EXCLUDE_SRCS =\
   s-linux.ads  s-vxwext.adb s-vxwext.ads s-win32.ads  s-winext.ads \
   s-stchop.ads s-stchop.adb \
   s-strcom.adb s-strcom.ads s-thread.ads \
+  s-qnx.ads \
 
 # ADA_EXCLUDE_SRCS without the sources used by the target
 ADA_EXCLUDE_FILES=$(filter-out \

[Ada] Add Ada 2022 Key function to sets containers

[Pierre-Marie de Rodat via Gcc-patches]

This patch adds the new Generic_Keys.Key function to the set children
of Ada.Containers.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/a-cbhase.ads, libgnat/a-cborse.ads,
libgnat/a-cihase.ads, libgnat/a-ciorse.ads,
libgnat/a-cohase.ads, libgnat/a-coorse.ads (Key): New function
that takes a Container parameter, implemented as an expression
function, so it is self explanatory (doesn't need a comment).diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads
--- a/gcc/ada/libgnat/a-cbhase.ads
+++ b/gcc/ada/libgnat/a-cbhase.ads
@@ -403,6 +403,9 @@ is
   --  Applies generic formal operation Key to the element of the node
   --  designated by Position.
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
   --  Searches (as per the key-based Find) for the node containing Key, and
   --  returns the associated element.


diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -262,6 +262,9 @@ is
 
   function Key (Position : Cursor) return Key_Type;
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
 
   procedure Replace


diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads
--- a/gcc/ada/libgnat/a-cihase.ads
+++ b/gcc/ada/libgnat/a-cihase.ads
@@ -389,6 +389,9 @@ is
   --  Applies generic formal operation Key to the element of the node
   --  designated by Position.
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
   --  Searches (as per the key-based Find) for the node containing Key, and
   --  returns the associated element.


diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
--- a/gcc/ada/libgnat/a-ciorse.ads
+++ b/gcc/ada/libgnat/a-ciorse.ads
@@ -270,6 +270,9 @@ is
 
   function Key (Position : Cursor) return Key_Type;
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
 
   procedure Replace


diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads
--- a/gcc/ada/libgnat/a-cohase.ads
+++ b/gcc/ada/libgnat/a-cohase.ads
@@ -401,6 +401,9 @@ is
   --  Applies generic formal operation Key to the element of the node
   --  designated by Position.
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
   --  Searches (as per the key-based Find) for the node containing Key, and
   --  returns the associated element.


diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -263,6 +263,9 @@ is
 
   function Key (Position : Cursor) return Key_Type;
 
+  function Key (Container : Set; Position : Cursor) return Key_Type is
+(Key (Element (Container, Position)));
+
   function Element (Container : Set; Key : Key_Type) return Element_Type;
 
   procedure Replace

[Ada] Do not make procedure call with only tag-indeternminate actuals dispatching

[Pierre-Marie de Rodat via Gcc-patches]

The RM 3.9.2(19) clause says that the controlling tag value is statically
determined to be the tag of the tagged type involved.  As a matter of fact,
the call would be made dispatching only as a by-product of the propagation
of the controlling tag value to the tag-indeternminate actuals, but that's
unnecessary and not done in the equivalent case of a procedure call with
both statically tagged and tag-indeternminate actuals.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_disp.adb (Check_Dispatching_Call): Merge the two special cases
where there are no controlling actuals but tag-indeternminate ones.diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -540,8 +540,10 @@ package body Sem_Disp is
   Control: Node_Id := Empty;
   Func   : Entity_Id;
   Subp_Entity: Entity_Id;
-  Indeterm_Ancestor_Call : Boolean := False;
-  Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning
+
+  Indeterm_Ctrl_Type : Entity_Id := Empty;
+  --  Type of a controlling formal whose actual is a tag-indeterminate call
+  --  whose result type is different from, but is an ancestor of, the type.
 
   Static_Tag : Node_Id := Empty;
   --  If a controlling formal has a statically tagged actual, the tag of
@@ -935,8 +937,7 @@ package body Sem_Disp is
   and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
   and then Is_Ancestor (Etype (Actual), Etype (Formal))
 then
-   Indeterm_Ancestor_Call := True;
-   Indeterm_Ctrl_Type := Etype (Formal);
+   Indeterm_Ctrl_Type := Etype (Formal);
 
 --  If the formal is controlling but the actual is not, the type
 --  of the actual is statically known, and may be used as the
@@ -946,39 +947,13 @@ package body Sem_Disp is
   and then Is_Entity_Name (Actual)
   and then Is_Tagged_Type (Etype (Actual))
 then
-   Static_Tag := Actual;
+   Static_Tag := Etype (Actual);
 end if;
 
 Next_Actual (Actual);
 Next_Formal (Formal);
  end loop;
 
- --  If the call doesn't have a controlling actual but does have an
- --  indeterminate actual that requires dispatching treatment, then an
- --  object is needed that will serve as the controlling argument for
- --  a dispatching call on the indeterminate actual. This can occur
- --  in the unusual situation of a default actual given by a tag-
- --  indeterminate call and where the type of the call is an ancestor
- --  of the type associated with a containing call to an inherited
- --  operation (see AI-239).
-
- --  Rather than create an object of the tagged type, which would
- --  be problematic for various reasons (default initialization,
- --  discriminants), the tag of the containing call's associated
- --  tagged type is directly used to control the dispatching.
-
- if No (Control)
-   and then Indeterm_Ancestor_Call
-   and then No (Static_Tag)
- then
-Control :=
-  Make_Attribute_Reference (Loc,
-Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
-Attribute_Name => Name_Tag);
-
-Analyze (Control);
- end if;
-
  if Present (Control) then
 
 --  Verify that no controlling arguments are statically tagged
@@ -1030,17 +1005,35 @@ package body Sem_Disp is
 
 Check_Direct_Call;
 
- --  If there is a statically tagged actual and a tag-indeterminate
- --  call to a function of the ancestor (such as that provided by a
- --  default), then treat this as a dispatching call and propagate
- --  the tag to the tag-indeterminate call(s).
-
- elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
-Control :=
-  Make_Attribute_Reference (Loc,
-Prefix =>
-  New_Occurrence_Of (Etype (Static_Tag), Loc),
-Attribute_Name => Name_Tag);
+ --  If the call doesn't have a controlling actual but does have an
+ --  indeterminate actual that requires dispatching treatment, then an
+ --  object is needed that will serve as the controlling argument for
+ --  a dispatching call on the indeterminate actual. This can occur
+ --  in the unusual situation of a default actual given by a tag-
+ --  indeterminate call and where the type of the call is an ancestor
+ --  of the type associated with a containing call to an inherited
+ --  operation (see AI-239).
+
+ --  Rather than create an object of the tagged type, which would
+ --  be problemat

[Ada] Call-initialize all controlled objects in place

[Pierre-Marie de Rodat via Gcc-patches]

This changes the compiler to build in place almost all objects that need
finalization and are initialized with the result of a function call, thus
saving a pair of Adjust/Finalize calls for the anonymous return object.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Expand_N_Object_Declaration): Don't adjust the object
if the expression is a function call.
: Return true if the object needs finalization
and is initialized  with the result of a function call returned on
the secondary stack.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Add Use_Sec_Stack boolean
parameter.  Early return if the parent is an object declaration and
Use_Sec_Stack is false.
(Expand_Call_Helper): Adjust call to Expand_Ctrl_Function_Call.
* exp_ch7.adb (Find_Last_Init): Be prepared for initialization still
present in the object declaration.
* sem_ch3.adb (Analyze_Object_Declaration): Call the predicates
Needs_Secondary_Stack and Needs_Finalization to guard the renaming
optimization.diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6810,28 +6810,25 @@ package body Exp_Ch3 is
 
  --  If the object declaration appears in the form
 
- --Obj : Ctrl_Typ := Func (...);
+ --Obj : Typ := Func (...);
 
- --  where Ctrl_Typ is controlled but not immutably limited type, then
- --  the expansion of the function call should use a dereference of the
- --  result to reference the value on the secondary stack.
+ --  where Typ both needs finalization and is returned on the secondary
+ --  stack, the object declaration can be rewritten into a dereference
+ --  of the reference to the result built on the secondary stack (see
+ --  Expand_Ctrl_Function_Call for this expansion of the call):
 
- --Obj : Ctrl_Typ renames Func (...).all;
+ --type Axx is access all Typ;
+ --Rxx : constant Axx := Func (...)'reference;
+ --Obj : Typ renames Rxx.all;
 
- --  As a result, the call avoids an extra copy. This an optimization,
- --  but it is required for passing ACATS tests in some cases where it
- --  would otherwise make two copies. The RM allows removing redunant
- --  Adjust/Finalize calls, but does not allow insertion of extra ones.
+ --  This avoids an extra copy and the pair of Adjust/Finalize calls.
 
- --  This part is disabled for now, because it breaks GNAT Studio
- --  builds
-
- (False -- ???
+ (not Is_Library_Level_Entity (Def_Id)
 and then Nkind (Expr_Q) = N_Explicit_Dereference
 and then not Comes_From_Source (Expr_Q)
 and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
-and then Nkind (Object_Definition (N)) in N_Has_Entity
-and then (Needs_Finalization (Entity (Object_Definition (N)
+and then Needs_Finalization (Typ)
+and then not Is_Class_Wide_Type (Typ))
 
--  If the initializing expression is for a variable with attribute
--  OK_To_Rename set, then transform:
@@ -6843,8 +6840,7 @@ package body Exp_Ch3 is
-- Obj : Typ renames Expr;
 
--  provided that Obj is not aliased. The aliased case has to be
-   --  excluded in general because Expr will not be aliased in
-   --  general.
+   --  excluded in general because Expr will not be aliased in general.
 
or else
  (not Aliased_Present (N)
@@ -6853,7 +6849,7 @@ package body Exp_Ch3 is
and then OK_To_Rename (Entity (Expr_Q))
and then Is_Entity_Name (Obj_Def));
   begin
- --  Return False if there are any aspect specifications, because
+ --  ??? Return False if there are any aspect specifications, because
  --  otherwise we duplicate that corresponding implicit attribute
  --  definition, and call Insert_Action, which has no place to insert
  --  the attribute definition. The attribute definition is stored in
@@ -7423,16 +7419,18 @@ package body Exp_Ch3 is
end if;
 end if;
 
---  If the type is controlled and not inherently limited, then
---  the target is adjusted after the copy and attached to the
---  finalization list. However, no adjustment is done in the case
---  where the object was initialized by a call to a function whose
---  result is built in place, since no copy occurred. Similarly, no
---  adjustment is required if we are going to rewrite the object
---  declaration into a renaming declaration.
+--  If the type needs finalization and is not inherently limited,
+--  then the target is adjus

[Ada] Fix missing error on 'Access of constrained array

[Pierre-Marie de Rodat via Gcc-patches]

For X'Access, the designated subtype of the access type must statically
match the nominal subtype of X.  This patch fixes a bug where the error
was not detected when there is an unrelated declaration of the form "Y :
T := X;", where T is an unconstrained array subtype.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_util.adb (Expand_Subtype_From_Expr): Generate a new
subtype when Is_Constr_Subt_For_UN_Aliased is True, so the
Is_Constr_Subt_For_U_Nominal flag will not be set on the
preexisting subtype.
* sem_attr.adb, sem_ch3.adb: Minor.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -113,7 +113,7 @@ package body Exp_Util is
  (Header_Num => Type_Map_Header,
   Key=> Entity_Id,
   Element=> Node_Or_Entity_Id,
-  No_element => Empty,
+  No_Element => Empty,
   Hash   => Type_Map_Hash,
   Equal  => "=");
 
@@ -5730,8 +5730,17 @@ package body Exp_Util is
 or else not Is_Array_Type (Exp_Typ)
 or else not Aliased_Present (N))
   then
- if Is_Itype (Exp_Typ) then
+ if Is_Itype (Exp_Typ)
 
+   --  If Exp_Typ was created for a previous declaration whose nominal
+   --  subtype is unconstrained, and that declaration is aliased,
+   --  we need to generate a new subtype, because otherwise the
+   --  Is_Constr_Subt_For_U_Nominal flag will be set on the wrong
+   --  subtype, causing failure to detect non-statically-matching
+   --  subtypes on 'Access of the previously-declared object.
+
+   and then not Is_Constr_Subt_For_UN_Aliased (Exp_Typ)
+ then
 --  Within an initialization procedure, a selected component
 --  denotes a component of the enclosing record, and it appears as
 --  an actual in a call to its own initialization procedure. If
@@ -5770,7 +5779,7 @@ package body Exp_Util is
 --  This type is marked as an itype even though it has an explicit
 --  declaration since otherwise Is_Generic_Actual_Type can get
 --  set, resulting in the generation of spurious errors. (See
---  sem_ch8.Analyze_Package_Renaming and sem_type.covers)
+--  sem_ch8.Analyze_Package_Renaming and Sem_Type.Covers.)
 
 Set_Is_Itype (T);
 Set_Associated_Node_For_Itype (T, Exp);


diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -11632,9 +11632,7 @@ package body Sem_Attr is
end if;
 end if;
 
-if (Attr_Id = Attribute_Access
-  or else
-Attr_Id = Attribute_Unchecked_Access)
+if Attr_Id in Attribute_Access | Attribute_Unchecked_Access
   and then (Ekind (Btyp) = E_General_Access_Type
  or else Ekind (Btyp) = E_Anonymous_Access_Type)
 then


diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -18276,7 +18276,7 @@ package body Sem_Ch3 is
 
begin
   --  If the parent is a component_definition node we climb to the
-  --  component_declaration node
+  --  component_declaration node.
 
   if Nkind (P) = N_Component_Definition then
  P := Parent (P);

[Ada] Enforce deferred constant completion rules

[Pierre-Marie de Rodat via Gcc-patches]

If a constrained subtype is given when a deferred constant is declared,
then the subtype given in the completion is required (at compile time)
to be subject to a statically matching constraint. This rule was not
properly enforced in some cases and constructs that should have been
rejected were incorrectly accepted.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch3.adb (Check_Possible_Deferred_Completion): Delete
Prev_Obj_Def formal parameter.  Reorganize code so that
statically matching check is also performed in the case where
the subtype given in the initial declaration is constrained and
the subtype given in the completion is not.diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -13126,7 +13126,6 @@ package body Sem_Ch3 is
 
   procedure Check_Possible_Deferred_Completion
 (Prev_Id  : Entity_Id;
- Prev_Obj_Def : Node_Id;
  Curr_Obj_Def : Node_Id);
   --  Determine whether the two object definitions describe the partial
   --  and the full view of a constrained deferred constant. Generate
@@ -13146,15 +13145,16 @@ package body Sem_Ch3 is
 
   procedure Check_Possible_Deferred_Completion
 (Prev_Id  : Entity_Id;
- Prev_Obj_Def : Node_Id;
  Curr_Obj_Def : Node_Id)
   is
+ Curr_Typ : Entity_Id;
+ Prev_Typ : constant Entity_Id := Etype (Prev_Id);
+ Anon_Acc : constant Boolean := Is_Anonymous_Access_Type (Prev_Typ);
+ Mismatch : Boolean := False;
   begin
- if Nkind (Prev_Obj_Def) = N_Subtype_Indication
-   and then Present (Constraint (Prev_Obj_Def))
-   and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
-   and then Present (Constraint (Curr_Obj_Def))
- then
+ if Anon_Acc then
+null;
+ elsif Nkind (Curr_Obj_Def) = N_Subtype_Indication then
 declare
Loc: constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id  := Make_Temporary (Loc, 'S');
@@ -13167,13 +13167,32 @@ package body Sem_Ch3 is
 begin
Insert_Before_And_Analyze (N, Decl);
Set_Etype (Id, Def_Id);
-
-   if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
-  Error_Msg_Sloc := Sloc (Prev_Id);
-  Error_Msg_N ("subtype does not statically match deferred "
-   & "declaration #", N);
-   end if;
+   Curr_Typ := Def_Id;
 end;
+ else
+Curr_Typ := Etype (Curr_Obj_Def);
+ end if;
+
+ if Anon_Acc then
+if Nkind (Curr_Obj_Def) /= N_Access_Definition then
+   Mismatch := True;
+elsif Has_Null_Exclusion (Prev_Typ)
+  and then not Null_Exclusion_Present (Curr_Obj_Def)
+then
+   Mismatch := True;
+end if;
+--  ??? Another check needed: mismatch if disagreement
+--  between designated types/profiles .
+ else
+Mismatch :=
+  Is_Constrained (Prev_Typ)
+and then not Subtypes_Statically_Match (Prev_Typ, Curr_Typ);
+ end if;
+
+ if Mismatch then
+Error_Msg_Sloc := Sloc (Prev_Id);
+Error_Msg_N ("subtype does not statically match deferred "
+ & "declaration #", N);
  end if;
   end Check_Possible_Deferred_Completion;
 
@@ -13316,7 +13335,6 @@ package body Sem_Ch3 is
 
  Check_Possible_Deferred_Completion
(Prev_Id  => Prev,
-Prev_Obj_Def => Object_Definition (Parent (Prev)),
 Curr_Obj_Def => Obj_Def);
 
  Set_Full_View (Prev, Id);

[Ada] Use static stack allocation for small string if-expressions

[Pierre-Marie de Rodat via Gcc-patches]

This changes the expanded code generated for if-expressions of 1-dimensional
arrays to create a static temporary on the stack if a small upper bound can
be computed for the length of a subtype covering the result.  Static stack
allocation is preferred over dynamic allocation for code generation purpose.

This also contains a couple of enhancements to the support code for checks,
so as to avoid generating useless checks during the modified expansion.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* checks.adb (Apply_Length_Check_On_Assignment): Return early if
the Suppress_Assignment_Checks flag is set.
(Selected_Range_Checks): Deal with conditional expressions.
* exp_ch4.adb (Too_Large_Length_For_Array): New constant.
(Expand_Concatenate): Use it in lieu of Too_Large_Max_Length.
(Expand_N_If_Expression): If the result has a unidimensional array
type but the dependent expressions have constrained subtypes with
known bounds, create a static temporary on the stack with a subtype
covering the result.
(Get_First_Index_Bounds): Deal with string literals.
* uintp.ads (Uint_256): New deferred constant.
* sinfo.ads (Suppress_Assignment_Checks): Document new usage.diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2297,6 +2297,15 @@ package body Checks is
   Assign : constant Node_Id := Parent (Target);
 
begin
+  --  Do not apply length checks if parent is still an assignment statement
+  --  with Suppress_Assignment_Checks flag set.
+
+  if Nkind (Assign) = N_Assignment_Statement
+and then Suppress_Assignment_Checks (Assign)
+  then
+ return;
+  end if;
+
   --  No check is needed for the initialization of an object whose
   --  nominal subtype is unconstrained.
 
@@ -6462,7 +6471,7 @@ package body Checks is
   end if;
 
   --  Do not set range check flag if parent is assignment statement or
-  --  object declaration with Suppress_Assignment_Checks flag set
+  --  object declaration with Suppress_Assignment_Checks flag set.
 
   if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration
 and then Suppress_Assignment_Checks (Parent (N))
@@ -10500,6 +10509,11 @@ package body Checks is
   --  Returns expression to compute:
   --N'First or N'Last using Duplicate_Subexpr_No_Checks
 
+  function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean;
+  function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean;
+  --  Return True if N is a conditional expression whose dependent
+  --  expressions are all known and greater/lower than or equal to V.
+
   function Range_E_Cond
 (Exptyp : Entity_Id;
  Typ: Entity_Id;
@@ -10522,6 +10536,16 @@ package body Checks is
   --  Return expression to compute:
   --Exp'First < Typ'First or else Exp'Last > Typ'Last
 
+  function "<" (Left, Right : Node_Id) return Boolean
+  is (if Is_Floating_Point_Type (S_Typ)
+  then Expr_Value_R (Left) < Expr_Value_R (Right)
+  else Expr_Value   (Left) < Expr_Value   (Right));
+  function "<=" (Left, Right : Node_Id) return Boolean
+  is (if Is_Floating_Point_Type (S_Typ)
+  then Expr_Value_R (Left) <= Expr_Value_R (Right)
+  else Expr_Value   (Left) <= Expr_Value   (Right));
+  --  Convenience comparison functions of integer or floating point values
+
   ---
   -- Add_Check --
   ---
@@ -10702,6 +10726,60 @@ package body Checks is
   Make_Integer_Literal (Loc, Indx)));
   end Get_N_Last;
 
+  -
+  -- Is_Cond_Expr_Ge --
+  -
+
+  function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean is
+  begin
+ --  Only if expressions are relevant for the time being
+
+ if Nkind (N) = N_If_Expression then
+declare
+   Cond  : constant Node_Id := First (Expressions (N));
+   Thenx : constant Node_Id := Next (Cond);
+   Elsex : constant Node_Id := Next (Thenx);
+
+begin
+   return Compile_Time_Known_Value (Thenx)
+ and then V <= Thenx
+ and then
+   ((Compile_Time_Known_Value (Elsex) and then V <= Elsex)
+or else Is_Cond_Expr_Ge (Elsex, V));
+end;
+
+ else
+return False;
+ end if;
+  end Is_Cond_Expr_Ge;
+
+  -
+  -- Is_Cond_Expr_Le --
+  -
+
+  function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean is
+  begin
+ --  Only if expressions are relevant for the time being
+
+ if Nkind (N) = N_If_Expression then
+declare
+   Cond  : constant Node_Id := First (Ex

[Ada] Remove old vxworks6 from Makefile.rtl

[Pierre-Marie de Rodat via Gcc-patches]

Pre vxworks7 code excepting legacy vxworks6 code is removed from
Makefile.rtl and unused files are deleted.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* Makefile.rtl (*vxworks*): Remove most pre-vxworks7 code.
* vxworks-arm-link.spec: Remove.
* vxworks-e500-link.spec: Likewise.
* vxworks-smp-arm-link.spec: Likewise.
* vxworks-smp-e500-link.spec: Likewise.
* vxworks-smp-x86-link.spec: Likewise.
* libgnat/system-vxworks-arm-rtp-smp.ads: Likewise.
* libgnat/system-vxworks-arm-rtp.ads: Likewise.
* libgnat/system-vxworks-arm.ads: Likewise.
* libgnat/system-vxworks-e500-kernel.ads: Likewise.
* libgnat/system-vxworks-e500-rtp-smp.ads: Likewise.
* libgnat/system-vxworks-e500-rtp.ads: Likewise.
* libgnat/system-vxworks-x86-kernel.ads: Likewise.
* libgnat/system-vxworks-x86-rtp-smp.ads: Likewise.
* libgnat/system-vxworks-x86-rtp.ads: Likewise.

patch.diff.gz
Description: application/gzip

[Ada] Remove unimplemented convert_addresses declaration

[Pierre-Marie de Rodat via Gcc-patches]

convert_addresses is declared in adaint.h but is never referenced, so
remove it.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* adaint.h (convert_addresses): Remove function declaration.diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -254,8 +254,6 @@ extern char  *__gnat_to_host_dir_spec  (char *, int);
 extern char  *__gnat_to_host_file_spec (char *);
 extern char  *__gnat_to_canonical_path_spec	   (char *);
 extern void   __gnat_adjust_os_resource_limits	   (void);
-extern void   convert_addresses			   (const char *, void *, int,
-		void *, int *);
 extern int__gnat_copy_attribs		   (char *, char *, int);
 extern int__gnat_feof		  	   (FILE *);
 extern int__gnat_ferror(FILE *);

[Ada] Fix clearly unintentional dead analysis of attribute Code_Address

[Pierre-Marie de Rodat via Gcc-patches]

A new warning about unreachable code that follows calls to procedures
with No_Return would flag a clearly unintentional dead call to
Set_Address_Taken in analysis of Code_Address attribute.

This patch resurrects the dead code, which is worth fixing regardless of
the new warning.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb (Analyze_Attribute): Move call to
Set_Address_Taken so that it is executed when the prefix
attribute is legal.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3746,11 +3746,11 @@ package body Sem_Attr is
 Ekind (Entity (P)) /= E_Procedure)
  then
 Error_Attr ("invalid prefix for % attribute", P);
-Set_Address_Taken (Entity (P));
 
  --  Issue an error if the prefix denotes an eliminated subprogram
 
  else
+Set_Address_Taken (Entity (P));
 Check_For_Eliminated_Subprogram (P, Entity (P));
  end if;
 

[Ada] Remove redundant guards in detection of unreachable code

[Pierre-Marie de Rodat via Gcc-patches]

Routine Check_Unreachable_Code is only called on nodes belonging to a
list of statements (and it wouldn't make sense to call it on anything
else).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch5.adb (Check_Unreachable_Code): Remove redundant guard;
the call to Present wasn't needed either.diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4398,7 +4398,7 @@ package body Sem_Ch5 is
   P  : Node_Id;
 
begin
-  if Is_List_Member (N) and then Comes_From_Source (N) then
+  if Comes_From_Source (N) then
  Nxt := Original_Node (Next (N));
 
  --  Skip past pragmas
@@ -4415,8 +4415,7 @@ package body Sem_Ch5 is
 
  --  Otherwise see if we have a real statement following us
 
- elsif Present (Nxt)
-   and then Comes_From_Source (Nxt)
+ elsif Comes_From_Source (Nxt)
and then Is_Statement (Nxt)
  then
 --  Special very annoying exception. If we have a return that

[Ada] Remove comment about a long gone formal verification mode

[Pierre-Marie de Rodat via Gcc-patches]

Remove outdated a comment about the very first SPARK experiments
in GNAT.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch6.adb (Check_Missing_Return): Remove outdated comment.diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -2987,9 +2987,7 @@ package body Sem_Ch6 is
 
   procedure Check_Missing_Return;
   --  Checks for a function with a no return statements, and also performs
-  --  the warning checks implemented by Check_Returns. In formal mode, also
-  --  verify that a function ends with a RETURN and that a procedure does
-  --  not contain any RETURN.
+  --  the warning checks implemented by Check_Returns.
 
   function Disambiguate_Spec return Entity_Id;
   --  When a primitive is declared between the private view and the full

[Ada] Add RM reference to check for functions without a return statement

[Pierre-Marie de Rodat via Gcc-patches]

Add comment to explain why we have an error and not just a warning.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch6.adb (Check_Missing_Return): Add reference to an RM rule.diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -3568,6 +3568,10 @@ package body Sem_Ch6 is
Id := Body_Id;
 end if;
 
+--  A function body shall contain at least one return statement
+--  that applies to the function body, unless the function contains
+--  code_statements; RM 6.5(5).
+
 if Return_Present (Id) then
Check_Returns (HSS, 'F', Missing_Ret);
 

[Ada] Combine system.ads files - vxworks6 constants.

[Pierre-Marie de Rodat via Gcc-patches]

Systemitize Word_Size and Memory_Size declarations rather than hard code
with numerical values or OS specific Long_Integer size.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/system-vxworks-ppc-kernel.ads (Word_Size): Compute
based on Standard'Word_Size.
(Memory_Size): Compute based on Word_Size.
* libgnat/system-vxworks-ppc-rtp-smp.ads: Likewise.
* libgnat/system-vxworks-ppc-rtp.ads: Likewise.diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
--- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
 
Storage_Unit : constant := 8;
-   Word_Size: constant := 32;
-   Memory_Size  : constant := 2 ** 32;
+   Word_Size: constant := Standard'Word_Size;
+   Memory_Size  : constant := 2 ** Word_Size;
 
--  Address comparison
 


diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads
@@ -71,8 +71,8 @@ package System is
Null_Address : constant Address;
 
Storage_Unit : constant := 8;
-   Word_Size: constant := 32;
-   Memory_Size  : constant := 2 ** 32;
+   Word_Size: constant := Standard'Word_Size;
+   Memory_Size  : constant := 2 ** Word_Size;
 
--  Address comparison
 


diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
--- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
+++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads
@@ -71,8 +71,8 @@ package System is
Null_Address : constant Address;
 
Storage_Unit : constant := 8;
-   Word_Size: constant := 32;
-   Memory_Size  : constant := 2 ** 32;
+   Word_Size: constant := Standard'Word_Size;
+   Memory_Size  : constant := 2 ** Word_Size;
 
--  Address comparison
 

[Ada] Perform object rewriting as renaming only in the expander

[Pierre-Marie de Rodat via Gcc-patches]

The rewriting as renaming optimization for object declarations is done
partly during analysis, guarded with Expander_Active, and partly during
expansion, so it makes sense to do it entirely during expansion.

This merges the two cases and removes obsolete or unnecessary conditions
guarding the transformation in the process.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Expand_N_Object_Declaration): Rewrite as a renaming
for any nonaliased local object with nominal unconstrained subtype
originally initialized with the result of a function call that has
been rewritten as the dereference of a reference to the result.
* sem_ch3.adb (Analyze_Object_Declaration): Do not do it herediff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7675,59 +7675,54 @@ package body Exp_Ch3 is
 
 Rewrite_As_Renaming :=
 
-  --  If the object declaration appears in the form
+  --  The declaration cannot be rewritten if it has got constraints
+  --  in other words the nominal subtype must be unconstrained.
 
-  --Obj : Typ := Func (...);
+  Is_Entity_Name (Original_Node (Obj_Def))
 
-  --  where Typ needs finalization and is returned on the secondary
-  --  stack, the declaration can be rewritten into a dereference of
-  --  the reference to the result built on the secondary stack (see
-  --  Expand_Ctrl_Function_Call for this expansion of the call):
+--  The aliased case has to be excluded because the expression
+--  will not be aliased in the general case.
 
-  --type Axx is access all Typ;
-  --Rxx : constant Axx := Func (...)'reference;
-  --Obj : Typ renames Rxx.all;
+and then not Aliased_Present (N)
 
-  --  This avoids an extra copy and a pair of Adjust/Finalize calls
+--  If the object declaration originally appears in the form
 
-  ((not Is_Library_Level_Entity (Def_Id)
- and then Nkind (Expr_Q) = N_Explicit_Dereference
- and then not Comes_From_Source (Expr_Q)
- and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
- and then Needs_Finalization (Typ)
- and then not Is_Class_Wide_Type (Typ))
+--Obj : Typ := Func (...);
 
---  If the initializing expression is for a variable with flag
---  OK_To_Rename set, then transform:
+--  and has been rewritten as the dereference of a reference
+--  to the function result built either on the primary or the
+--  secondary stack, then the declaration can be rewritten as
+--  the renaming of this dereference:
 
--- Obj : Typ := Expr;
+--type Axx is access all Typ;
+--Rxx : constant Axx := Func (...)'reference;
+--Obj : Typ renames Rxx.all;
 
---  into
+--  This avoids an extra copy and, in the case where Typ needs
+--  finalization, a pair of Adjust/Finalize calls (see below).
 
--- Obj : Typ renames Expr;
+and then
+  ((not Is_Library_Level_Entity (Def_Id)
+ and then Nkind (Expr_Q) = N_Explicit_Dereference
+ and then not Comes_From_Source (Expr_Q)
+ and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
+ and then not Is_Class_Wide_Type (Typ))
 
---  provided that Obj is not aliased. The aliased case has to
---  be excluded because Expr will not be aliased in general.
+   --  If the initializing expression is a variable with the
+   --  flag OK_To_Rename set, then transform:
 
-   or else (not Aliased_Present (N)
- and then (OK_To_Rename_Ref (Expr_Q)
-or else
-   (Nkind (Expr_Q) = N_Slice
- and then
-OK_To_Rename_Ref (Prefix (Expr_Q))
+   -- Obj : Typ := Expr;
 
-  --  The declaration cannot be rewritten if it has got constraints
-  --  in other words the nominal subtype must be unconstrained.
+   --  into
+
+   -- Obj : Typ renames Expr;
 
-  and then Is_Entity_Name (Original_Node (Obj_Def))
+   or else OK_To_Rename_Ref (Expr_Q)
 
-  --  ??? Likewise if there are any aspect specifications, because
-  --  otherwise we duplicate that corresponding implicit attribute
-  -- 

[Ada] Remove redundant guard for call to List_Length with a No_List

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup related to a new detection of uninitialised local scalar
objects; semantics is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch5.adb (Analyze_Block_Statement): Call to List_Length with
No_List is safe and will return zero.diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1376,11 +1376,7 @@ package body Sem_Ch5 is
  --  Initialize unblocked exit count for statements of begin block
  --  plus one for each exception handler that is present.
 
- Unblocked_Exit_Count := 1;
-
- if Present (EH) then
-Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
- end if;
+ Unblocked_Exit_Count := 1 + List_Length (EH);
 
  --  If a label is present analyze it and mark it as referenced
 

[Ada] Cleanup in error about unreachable code

[Pierre-Marie de Rodat via Gcc-patches]

Cleanup only; behaviour is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch5.adb (Check_Unreachable_Code): Avoid explicit use of
Sloc; this should also help when we finally use Source_Span for
prettier error messages.diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4468,8 +4468,7 @@ package body Sem_Ch5 is
   end loop;
end if;
 
-   Error_Msg
- ("??unreachable code!", Sloc (Error_Node), Error_Node);
+   Error_Msg_N ("??unreachable code!", Error_Node);
 end if;
 
  --  If the unconditional transfer of control instruction is the

[Ada] Spurious error on qualified prefix in Pack.Func'Result

[Pierre-Marie de Rodat via Gcc-patches]

When using a qualified name such as Pack.Func as the prefix of a 'Result
attribute reference, the prefix is not fully resolved and may contain a
chain of homonyms. Look for the expected function in the homonym chain
instead of issuing an error if the first one is not the expected one.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb (Analyze_Attribute): Take into account the
possibility of homonyms.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -5835,6 +5835,12 @@ package body Sem_Attr is
 
 elsif Present (Over_Id) and then Pref_Id = Over_Id then
return True;
+
+--  When a qualified name is used for the prefix, homonyms may come
+--  before the current function in the homonym chain.
+
+elsif Has_Homonym (Pref_Id) then
+   return Denote_Same_Function (Homonym (Pref_Id), Spec_Id);
 end if;
 
 --  Otherwise the prefix does not denote the related subprogram

[Ada] Cleanup repeated code for aggregate constraints checks

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup related to examining uses of Check_Unset_Reference for
improved detection of uninitialised scalar objects. Semantics is
unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_util.adb (Aggregate_Constraint_Checks): Fix whitespace;
refactor repeated code; replace a ??? comment with an
explanation based on the comment for the routine spec.diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1153,7 +1153,7 @@ package body Sem_Util is
  (Exp   : Node_Id;
   Check_Typ : Entity_Id)
is
-  Exp_Typ : constant Entity_Id  := Etype (Exp);
+  Exp_Typ : constant Entity_Id := Etype (Exp);
 
begin
   if Raises_Constraint_Error (Exp) then
@@ -1236,12 +1236,12 @@ package body Sem_Util is
 and then Is_Scalar_Type (Check_Typ)
 and then Exp_Typ /= Check_Typ
   then
+ --  If expression is a constant, it is worthwhile checking whether it
+ --  is a bound of the type.
+
  if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
  then
---  If expression is a constant, it is worthwhile checking whether
---  it is a bound of the type.
-
 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
  and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
   or else
@@ -1249,20 +1249,15 @@ package body Sem_Util is
  and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
 then
return;
-
-else
-   Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
-   Analyze_And_Resolve (Exp, Check_Typ);
-   Check_Unset_Reference (Exp);
 end if;
+ end if;
 
- --  Could use a comment on this case ???
+ --  Change Exp into Check_Typ'(Exp) to ensure that range checks are
+ --  performed at run time.
 
- else
-Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
-Analyze_And_Resolve (Exp, Check_Typ);
-Check_Unset_Reference (Exp);
- end if;
+ Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+ Analyze_And_Resolve (Exp, Check_Typ);
+ Check_Unset_Reference (Exp);
 
   end if;
end Aggregate_Constraint_Checks;

[Ada] Remove exception propagation during bootstrap

[Pierre-Marie de Rodat via Gcc-patches]

To help the bootstrap path, we want to keep the compiler free from any
exception propagation during bootstrap. This has been broken recently in
various places.

Also introduce a way to more easily detect such breakage via the
-DNO_EXCEPTION_PROPAGATION which can now be used as part of BOOT_CFLAGS.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_imgv.adb (Build_Enumeration_Image_Tables): Also disable
perfect hash in GNAT_Mode.
* raise-gcc.c (__gnat_Unwind_RaiseException): Add support for
disabling exception propagation.
* sem_eval.adb (Compile_Time_Known_Value): Update comment and
remove wrong call to Check_Error_Detected.
* sem_prag.adb (Check_Loop_Pragma_Grouping, Analyze_Pragma):
Remove exception propagation during bootstrap.diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -289,12 +289,14 @@ package body Exp_Imgv is
  --  If the unit where the type is declared is the main unit, and the
  --  number of literals is greater than Threshold_For_Size when we are
  --  optimizing for size, and the restriction No_Implicit_Loops is not
- --  active, and -gnatd_h is not specified, generate the hash function.
+ --  active, and -gnatd_h is not specified, and not GNAT_Mode, generate
+ --  the hash function.
 
  if In_Main_Unit
and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
and then not Restriction_Active (No_Implicit_Loops)
and then not Debug_Flag_Underscore_H
+   and then not GNAT_Mode
  then
 declare
LB : constant Positive := 2 * Positive (Nlit) + 1;


diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -1377,6 +1377,10 @@ __gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED,
 _Unwind_Reason_Code
 __gnat_Unwind_RaiseException (_Unwind_Exception *e)
 {
+#ifdef NO_EXCEPTION_PROPAGATION
+  abort();
+#endif
+
 #ifdef __USING_SJLJ_EXCEPTIONS__
   return _Unwind_SjLj_RaiseException (e);
 #else


diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -1816,10 +1816,10 @@ package body Sem_Eval is
 
begin
   --  Never known at compile time if bad type or raises Constraint_Error
-  --  or empty (latter case occurs only as a result of a previous error).
+  --  or empty (which can occur as a result of a previous error or in the
+  --  case of e.g. an imported constant).
 
   if No (Op) then
- Check_Error_Detected;
  return False;
 
   elsif Op = Error


diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6152,15 +6152,11 @@ package body Sem_Prag is
  
 
  procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
-Stop_Search : exception;
---  This exception is used to terminate the recursive descent of
---  routine Check_Grouping.
-
-procedure Check_Grouping (L : List_Id);
+function Check_Grouping (L : List_Id) return Boolean;
 --  Find the first group of pragmas in list L and if successful,
 --  ensure that the current pragma is part of that group. The
---  routine raises Stop_Search once such a check is performed to
---  halt the recursive descent.
+--  routine returns True once such a check is performed to
+--  stop the analysis.
 
 procedure Grouping_Error (Prag : Node_Id);
 pragma No_Return (Grouping_Error);
@@ -6171,7 +6167,7 @@ package body Sem_Prag is
 -- Check_Grouping --
 
 
-procedure Check_Grouping (L : List_Id) is
+function Check_Grouping (L : List_Id) return Boolean is
HSS  : Node_Id;
Stmt : Node_Id;
Prag : Node_Id := Empty; -- init to avoid warning
@@ -6219,7 +6215,7 @@ package body Sem_Prag is
--  Stop the search as the placement is legal.
 
if Stmt = N then
-  raise Stop_Search;
+  return True;
 
--  Skip group members, but keep track of the
--  last pragma in the group.
@@ -6266,15 +6262,21 @@ package body Sem_Prag is
   elsif Nkind (Stmt) = N_Block_Statement then
  HSS := Handled_Statement_Sequence (Stmt);
 
- Check_Grouping (Declarations (Stmt));
+ if Check_Grouping (Declarations (Stmt)) then
+return True;
+ end if;
 
  if Present (HSS) then
-

[Ada] Remove unnecessary dead code after calls to nonreturning procedures

[Pierre-Marie de Rodat via Gcc-patches]

A new warning about unreachable code that follows calls to procedures
with No_Return would flag some dead defensive code. Comments next to
this code suggest that it was added to please some ancient version of
the compiler, but recent releases of GNAT do not require such a code.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gnatls.adb (Corresponding_Sdep_Entry): Remove dead return
statement in defensive path; there is another return statement
for a normal execution of this routine, so rule Ada RM 6.5(5),
which requires function to have at least one return statement is
still satisfied.
(Gnatls): Remove dead, call to nonreturning Exit_Program after
Output_License_Information which itself does not return.
* libgnat/a-exstat.adb (Bad_EO): Remove raise statement that was
meant to please some ancient version of GNAT.
* libgnat/g-awk.adb (Raise_With_Info): Likewise.
* sem_attr.adb (Check_Reference): Remove dead return statement;
rule Ada RM 6.5(5), which requires function to have at least one
return statement is still satisfied.
(Analyze_Attribute): Remove dead exit statement.
(Check_Reference): Same as above.
* sem_ch12.adb (Instantiate_Formal_Package): Remove dead raise
statement; it was inconsistent with other calls to
Abandon_Instantiation, which are not followed by a raise
statement.
* sem_prag.adb (Process_Convention): Remove dead defensive
assignment.
(Interrupt_State): Remove dead defensive exit statement.
(Do_SPARK_Mode): Likewise.
* sfn_scan.adb (Scan_String): Remove dead defensive assignment.diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -319,7 +319,6 @@ procedure Gnatls is
   Write_Eol;
   Error_Msg ("wrong ALI format, can't find dependency line for $ in {");
   Exit_Program (E_Fatal);
-  return No_Sdep_Id;
end Corresponding_Sdep_Entry;
 
-
@@ -2051,7 +2050,6 @@ begin
if License then
   if Arg_Count = 2 then
  Output_License_Information;
- Exit_Program (E_Success);
 
   else
  Set_Standard_Error;


diff --git a/gcc/ada/libgnat/a-exstat.adb b/gcc/ada/libgnat/a-exstat.adb
--- a/gcc/ada/libgnat/a-exstat.adb
+++ b/gcc/ada/libgnat/a-exstat.adb
@@ -109,13 +109,6 @@ package body Stream_Attributes is
  Raise_Exception
(Program_Error'Identity,
 "bad exception occurrence in stream input");
-
- --  The following junk raise of Program_Error is required because
- --  this is a No_Return procedure, and unfortunately Raise_Exception
- --  can return (this particular call can't, but the back end is not
- --  clever enough to know that).
-
- raise Program_Error;
   end Bad_EO;
 
   procedure Next_String is


diff --git a/gcc/ada/libgnat/g-awk.adb b/gcc/ada/libgnat/g-awk.adb
--- a/gcc/ada/libgnat/g-awk.adb
+++ b/gcc/ada/libgnat/g-awk.adb
@@ -1211,7 +1211,6 @@ package body GNAT.AWK is
   Exceptions.Raise_Exception
 (E,
  '[' & Filename & ':' & Line & "] " & Message);
-  raise Constraint_Error; -- to please GNAT as this is a No_Return proc
end Raise_With_Info;
 
---


diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4747,7 +4747,6 @@ package body Sem_Attr is
   Error_Attr
 ("prefix of attribute % cannot reference local entities",
  Nod);
-  return Abandon;
else
   return OK;
end if;
@@ -4989,7 +4988,6 @@ package body Sem_Attr is
 else
Error_Attr
  ("attribute % cannot appear in body or accept statement", N);
-   exit;
 end if;
  end loop;
 
@@ -5383,7 +5381,6 @@ package body Sem_Attr is
   Error_Attr
 ("prefix of attribute % cannot reference local entities",
  Nod);
-  return Abandon;
 
--  Otherwise keep inspecting the prefix
 


diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -10572,7 +10572,6 @@ package body Sem_Ch12 is
  Error_Msg_N
("expect package instance to instantiate formal", Actual);
  Abandon_Instantiation (Actual);
- raise Program_Error;
 
   else
  Actual_Pack := Entity (Actual);


diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -8336,7 +8336,6 @@ package body Sem_Prag is
Error_Pragma_Arg
  ("argument of pragma% must be subprogram or access type",
   Arg2);
-   

[Ada] Remove repeated analysis for pragma Thread_Local_Storage

[Pierre-Marie de Rodat via Gcc-patches]

When analysing pragma Thread_Local_Storage its argument is analysed by
the call to Check_Arg_Is_Library_Level_Local_Name. There is no need to
reanalyse it. Code cleanup; behaviour is not affected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_prag.adb (Analyze_Pragma): Remove unnecessary call to
Analyze.diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -24861,7 +24861,6 @@ package body Sem_Prag is
 Check_Arg_Is_Library_Level_Local_Name (Arg1);
 
 Id := Get_Pragma_Arg (Arg1);
-Analyze (Id);
 
 if not Is_Entity_Name (Id)
   or else Ekind (Entity (Id)) /= E_Variable

[Ada] Annotate GNAT.Sockets with No_Return aspects

[Pierre-Marie de Rodat via Gcc-patches]

Opportunity for extra annotations spotted while fixing detection of
unreachable code that follows calls to procedures annotated with
No_Return.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/g-socket.adb (Raise_Host_Error): Add No_Return aspect.
(Raise_GAI_Error): Likewise.
* libgnat/g-socket.ads (Raise_Socket_Error): Likewise.diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb
--- a/gcc/ada/libgnat/g-socket.adb
+++ b/gcc/ada/libgnat/g-socket.adb
@@ -191,12 +191,14 @@ package body GNAT.Sockets is
else Value);
--  Removes dot at the end of error message
 
-   procedure Raise_Host_Error (H_Error : Integer; Name : String);
+   procedure Raise_Host_Error (H_Error : Integer; Name : String)
+   with No_Return;
--  Raise Host_Error exception with message describing error code (note
--  hstrerror seems to be obsolete) from h_errno. Name is the name
--  or address that was being looked up.
 
-   procedure Raise_GAI_Error (RC : C.int; Name : String);
+   procedure Raise_GAI_Error (RC : C.int; Name : String)
+   with No_Return;
--  Raise Host_Error with exception message in case of errors in
--  getaddrinfo and getnameinfo.
 


diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads
--- a/gcc/ada/libgnat/g-socket.ads
+++ b/gcc/ada/libgnat/g-socket.ads
@@ -1593,7 +1593,7 @@ private
Wait_For_A_Full_Reception : constant Request_Flag_Type := 4;
Send_End_Of_Record: constant Request_Flag_Type := 8;
 
-   procedure Raise_Socket_Error (Error : Integer);
+   procedure Raise_Socket_Error (Error : Integer) with No_Return;
--  Raise Socket_Error with an exception message describing the error code
--  from errno.
 

[Ada] Remove return statements after procedure calls that don't return

[Pierre-Marie de Rodat via Gcc-patches]

A new warning about unreachable code that follows calls to procedures
with No_Return would flag many unnecessary return statements. Those
returns statements were applied inconsistently, so this patch is
actually more a style cleanup.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb, sem_prag.adb: Remove dead return statements
after calls to Error_Attr, Error_Pragma, Error_Pragma_Arg and
Placement_Error. All these calls raise exceptions that are
handled to gently recover from errors.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1090,7 +1090,6 @@ package body Sem_Attr is
 
else
   Error_Attr ("% attribute cannot be applied to type", P);
-  return;
end if;
 end if;
  end if;
@@ -1429,7 +1428,6 @@ package body Sem_Attr is
 
 else
Placement_Error;
-   return;
 end if;
 
  --  'Old attribute reference ok in a _Postconditions procedure
@@ -1445,7 +1443,6 @@ package body Sem_Attr is
 
  else
 Placement_Error;
-return;
  end if;
 
  --  Find the related subprogram subject to the aspect or pragma
@@ -1715,14 +1712,12 @@ package body Sem_Attr is
 
 else
Placement_Error;
-   return;
 end if;
 
  --  Otherwise the placement of the attribute is illegal
 
  else
 Placement_Error;
-return;
  end if;
 
  --  Find the related subprogram subject to the aspect or pragma
@@ -3666,7 +3661,6 @@ package body Sem_Attr is
 
  else
 Error_Attr ("invalid entry name", N);
-return;
  end if;
 
  for J in reverse 0 .. Scope_Stack.Last loop
@@ -3945,7 +3939,6 @@ package body Sem_Attr is
else
   Error_Attr ("invalid entry family name", P);
end if;
-   return;
 
 else
Ent := Entity (Prefix (P));
@@ -3960,7 +3953,6 @@ package body Sem_Attr is
 
  else
 Error_Attr ("invalid entry name", N);
-return;
  end if;
 
  for J in reverse 0 .. Scope_Stack.Last loop
@@ -4479,7 +4471,6 @@ package body Sem_Attr is
 
  if not Legal or else No (Spec_Id) then
 Error_Attr ("attribute % must apply to entry family", P);
-return;
  end if;
 
  --  Legality checks
@@ -5898,7 +5889,6 @@ package body Sem_Attr is
 
  elsif not Legal then
 Error_Attr ("prefix of % attribute must be a function", P);
-return;
  end if;
 
  --  Attribute 'Result is part of a _Postconditions procedure. There is


diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -4585,7 +4585,6 @@ package body Sem_Prag is
 
  else
 Pragma_Misplaced;
-return;
  end if;
 
  --  If we get here, then the pragma is legal
@@ -4600,7 +4599,6 @@ package body Sem_Prag is
and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
  then
 Pragma_Misplaced;
-return;
 
  --  When the related context is an anonymous object created for a
  --  simple concurrent type, the type must be a task
@@ -4610,7 +4608,6 @@ package body Sem_Prag is
and then Ekind (Etype (Spec_Id)) /= E_Task_Type
  then
 Pragma_Misplaced;
-return;
  end if;
 
  --  A pragma that applies to a Ghost entity becomes Ghost for the
@@ -4926,7 +4923,6 @@ package body Sem_Prag is
 
  else
 Pragma_Misplaced;
-return;
  end if;
 
  Subp_Id := Defining_Entity (Subp_Decl);
@@ -4991,7 +4987,6 @@ package body Sem_Prag is
   N_Task_Body  | N_Task_Body_Stub
  then
 Pragma_Misplaced;
-return;
  end if;
 
  Body_Id := Defining_Entity (Body_Decl);
@@ -5002,14 +4997,12 @@ package body Sem_Prag is
 
  if No (Spec_Id) then
 Error_Pragma ("pragma % cannot apply to a stand alone body");
-return;
 
  --  Catch the case where the subprogram body is a subunit and acts as
  --  the third declaration of the subprogram.
 
  elsif Nkind (Parent (Body_Decl)) = N_Subunit then
 Error_Pragma ("pragma % cannot apply to a subunit");
-return;
  end if;
 
  --  A refined pragma can only apply to the body [stub] of a subprogram
@@ -5034,7 +5027,6 @@ package body Sem_Prag is
 Error_Pragma
   (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
& "subprogram declared in a package specification"));
-return;
 

[Ada] Misc cleanup related to finalization

[Pierre-Marie de Rodat via Gcc-patches]

This patch cleans up some code issues found while working on
finalization, and adds some debugging aids.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch7.adb: Change two constants Is_Protected_Body and
Is_Prot_Body to be Is_Protected_Subp_Body; these are not true
for protected bodies, but for protected subprogram bodies.
(Expand_Cleanup_Actions): No need to search for
Activation_Chain_Entity; just use Activation_Chain_Entity.
* sem_ch8.adb (Find_Direct_Name): Use Entyp constant.
* atree.adb, atree.ads, atree.h, nlists.adb, nlists.ads
(Parent): Provide nonoverloaded versions of Parent, so that they
can be easily found in the debugger.
* debug_a.adb, debug_a.ads: Clarify that we're talking about the
-gnatda switch; switches are case sensitive.  Print out the
Chars field if appropriate, which makes it easier to find things
in the output.
(Debug_Output_Astring): Simplify. Also fix an off-by-one
bug ("for I in Vbars'Length .." should have been "for I in
Vbars'Length + 1 ..").  Before, it was printing Debug_A_Depth +
1 '|' characters if Debug_A_Depth > Vbars'Length.diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -1966,7 +1966,7 @@ package body Atree is
   end if;
end Paren_Count;
 
-   function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is
+   function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id is
begin
   pragma Assert (Present (N));
 
@@ -1975,7 +1975,7 @@ package body Atree is
   else
  return Node_Or_Entity_Id (Link (N));
   end if;
-   end Parent;
+   end Node_Parent;
 
-
-- Present --
@@ -2292,12 +2292,12 @@ package body Atree is
-- Set_Parent --

 
-   procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
+   procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
begin
   pragma Assert (Present (N));
   pragma Assert (not In_List (N));
   Set_Link (N, Union_Id (Val));
-   end Set_Parent;
+   end Set_Node_Parent;
 

-- Set_Reporting_Proc --


diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -446,10 +446,15 @@ package Atree is
--  Tests given Id for equality with the Empty node. This allows notations
--  like "if No (Variant_Part)" as opposed to "if Variant_Part = Empty".
 
-   function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
+   function Node_Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
+   pragma Inline (Node_Parent);
+   function Parent (N : Node_Or_Entity_Id) return Node_Or_Entity_Id
+ renames Node_Parent;
pragma Inline (Parent);
--  Returns the parent of a node if the node is not a list member, or else
--  the parent of the list containing the node if the node is a list member.
+   --  Parent has the same name as the one in Nlists; Node_Parent can be used
+   --  more easily in the debugger.
 
function Paren_Count (N : Node_Id) return Nat;
pragma Inline (Paren_Count);
@@ -465,7 +470,10 @@ package Atree is
--  Note that this routine is used only in very peculiar cases. In normal
--  cases, the Original_Node link is set by calls to Rewrite.
 
-   procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id);
+   procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id);
+   pragma Inline (Set_Node_Parent);
+   procedure Set_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id)
+ renames Set_Node_Parent;
pragma Inline (Set_Parent);
 
procedure Set_Paren_Count (N : Node_Id; Val : Nat);


diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -35,7 +35,7 @@
 extern "C" {
 #endif
 
-#define Parent atree__parent
+#define Parent atree__node_parent
 extern Node_Id Parent (Node_Id);
 
 #define Original_Node atree__original_node


diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -25,6 +25,7 @@
 
 with Atree;  use Atree;
 with Debug;  use Debug;
+with Namet;  use Namet;
 with Sinfo;  use Sinfo;
 with Sinfo.Nodes;use Sinfo.Nodes;
 with Sinput; use Sinput;
@@ -33,7 +34,7 @@ with Output; use Output;
 package body Debug_A is
 
Debug_A_Depth : Natural := 0;
-   --  Output for the debug A flag is preceded by a sequence of vertical bar
+   --  Output for the -gnatda switch is preceded by a sequence of vertical bar
--  characters corresponding to the recursion depth of the actions being
--  recorded (analysis, expansion, resolution and evaluation of nodes)
--  This variable records the depth.
@@ -66,7 +67,7 @@ package body Debug_A is
 
procedure Debug_A_Entry (S : String; N : Node_Id) is
b

[Ada] Remove redundant protection against empty lists

[Pierre-Marie de Rodat via Gcc-patches]

Calls to First on No_List intentionally return Empty node, so explicit
guards against No_List are unnecessary. Code cleanup; semantics is
unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_code.adb (Setup_Asm_IO_Args): Remove guard against No_List.
* par_sco.adb (Process_Decisions): Likewise.
* sem_ch13.adb (Check_Component_List): Likewise.
* sem_ch6.adb (FCL): Likewise.diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb
--- a/gcc/ada/exp_code.adb
+++ b/gcc/ada/exp_code.adb
@@ -471,11 +471,7 @@ package body Exp_Code is
   --  Case of list of arguments
 
   elsif Nkind (Arg) = N_Aggregate then
- if Expressions (Arg) = No_List then
-Operand_Var := Empty;
- else
-Operand_Var := First (Expressions (Arg));
- end if;
+ Operand_Var := First (Expressions (Arg));
 
   --  Otherwise must be default (no operands) case
 


diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -480,13 +480,11 @@ package body Par_SCO is
   N : Node_Id;
 
begin
-  if L /= No_List then
- N := First (L);
- while Present (N) loop
-Process_Decisions (N, T, Pragma_Sloc);
-Next (N);
- end loop;
-  end if;
+  N := First (L);
+  while Present (N) loop
+ Process_Decisions (N, T, Pragma_Sloc);
+ Next (N);
+  end loop;
end Process_Decisions;
 
--  Version taking a node


diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -12135,24 +12135,22 @@ package body Sem_Ch13 is
 begin
--  Gather discriminants into Comp
 
-   if DS /= No_List then
-  Citem := First (DS);
-  while Present (Citem) loop
- if Nkind (Citem) = N_Discriminant_Specification then
-declare
-   Ent : constant Entity_Id :=
-   Defining_Identifier (Citem);
-begin
-   if Ekind (Ent) = E_Discriminant then
-  Ncomps := Ncomps + 1;
-  Comps (Ncomps) := Ent;
-   end if;
-end;
- end if;
+   Citem := First (DS);
+   while Present (Citem) loop
+  if Nkind (Citem) = N_Discriminant_Specification then
+ declare
+Ent : constant Entity_Id :=
+Defining_Identifier (Citem);
+ begin
+if Ekind (Ent) = E_Discriminant then
+   Ncomps := Ncomps + 1;
+   Comps (Ncomps) := Ent;
+end if;
+ end;
+  end if;
 
- Next (Citem);
-  end loop;
-   end if;
+  Next (Citem);
+   end loop;
 
--  Gather component entities into Comp
 


diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9988,17 +9988,8 @@ package body Sem_Ch6 is
  N2 : Node_Id;
 
   begin
- if L1 = No_List then
-N1 := Empty;
- else
-N1 := First (L1);
- end if;
-
- if L2 = No_List then
-N2 := Empty;
- else
-N2 := First (L2);
- end if;
+ N1 := First (L1);
+ N2 := First (L2);
 
  --  Compare two lists, skipping rewrite insertions (we want to compare
  --  the original trees, not the expanded versions).

[Ada] Fix dangling bounds for array result of BIP functions

[Pierre-Marie de Rodat via Gcc-patches]

The implementation of the build-in-place return protocol for functions
whose result type is an unconstrained array type generates dangling
references to local bounds built on the stack for the result as soon as
these bounds are not static.  The reason is that the implementation
treats the return object, either explicitly present in the source or
synthesized by the compiler, as a regular constrained object until very
late in the game, although it needs to be ultimately rewritten as the
renaming of the dereference of an allocator with unconstrained designated
type in order for the bounds to be part of the allocation.

Recently a partial fix was implemented for the case where the result is an
aggregate, by preventing the return object from being expanded after it has
been analyzed.  However, it does not work for the general case of extended
return statements, because the statements therein are still analyzed with
the constrained version of the return object so, after it is changed into
the unconstrained renaming, this yields (sub)type mismatches.

Therefore this change goes the other way around: it rolls back the partial
fix and instead performs the transformation of the return object into the
unconstrained renaming during the expansion of its declaration, in other
words before statements referencing it, if any, are analyzed, thus ensuring
that they see the final version of the object.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_aggr.adb (Expand_Array_Aggregate): Remove obsolete code.
Delay the expansion of aggregates initializing return objects of
build-in-place functions.
* exp_ch3.ads (Ensure_Activation_Chain_And_Master): Delete.
* exp_ch3.adb (Ensure_Activation_Chain_And_Master): Fold back to...
(Expand_N_Object_Declaration): ...here.
Perform the expansion of return objects of build-in-place functions
here instead of...
* exp_ch6.ads (Is_Build_In_Place_Return_Object): Declare.
* exp_ch6.adb (Expand_N_Extended_Return_Statement): ...here.
(Is_Build_In_Place_Result_Type): Alphabetize.
(Is_Build_In_Place_Return_Object): New predicate.
* exp_ch7.adb (Enclosing_Function): Delete.
(Process_Object_Declaration): Tidy up handling of return objects.
* sem_ch3.adb (Analyze_Object_Declaration): Do not decorate and
freeze the actual type if it is the same as the nominal type.
* sem_ch6.adb: Remove use and with clauses for Exp_Ch3.
(Analyze_Function_Return): Analyze again all return objects.
(Create_Extra_Formals): Do not force the definition of an Itype
if the subprogram is a compilation unit.

patch.diff.gz
Description: application/gzip

[Ada] qnx-7.1: ACATS cxag001 failure on qnx - realpath

[Pierre-Marie de Rodat via Gcc-patches]

The implementation of __gnat_full_name uses the CRTL realpath, however
this function returns a null string so use the default implementation
instead.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* cstreams.c (__gnat_full_name) [QNX]: Remove block.diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c
--- a/gcc/ada/cstreams.c
+++ b/gcc/ada/cstreams.c
@@ -202,19 +202,6 @@ __gnat_full_name (char *nam, char *buffer)
  getcwd approach instead. */
   realpath (nam, buffer);
 
-#elif defined (__QNX__)
-
-  int length;
-
-  if (__gnat_is_absolute_path (nam, strlen (nam)))
-realpath (nam, buffer);
-  else
-{
-  length = __gnat_max_path_len;
-  __gnat_get_current_dir (buffer, &length);
-  strncat (buffer, nam, __gnat_max_path_len - length - 1);
-}
-
 #elif defined (__vxworks)
 
   /* On VxWorks systems, an absolute path can be represented (depending on

[Ada] Fix comments mentioning ancient flags related to objects references

[Pierre-Marie de Rodat via Gcc-patches]

Flag May_Be_Modified under go a series of renamings between 1996 and
2002.  It was changed to Not_Assigned, then to Not_Source_Assigned and
finally to Never_Set_In_Source. Fix remaining references in comments.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_util.ads (Note_Possible_Modification): Fix occurrence of
May_Be_Modified in comment.
* sem_warn.ads (Check_Unset_Reference): Fix occurrence of
Not_Assigned in comment.diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2872,7 +2872,7 @@ package Sem_Util is
--  This routine is called if the sub-expression N maybe the target of
--  an assignment (e.g. it is the left side of an assignment, used as
--  an out parameters, or used as prefixes of access attributes). It
-   --  sets May_Be_Modified in the associated entity if there is one,
+   --  sets Never_Set_In_Source in the associated entity if there is one,
--  taking into account the rule that in the case of renamed objects,
--  it is the flag in the renamed object that must be set.
--


diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -86,15 +86,15 @@ package Sem_Warn is
--  N is the node for an expression which occurs in a reference position,
--  e.g. as the right side of an assignment. This procedure checks to see
--  if the node is a reference to a variable entity where the entity has
-   --  Not_Assigned set. If so, the Unset_Reference field is set if it is not
-   --  the first occurrence. No warning is posted, instead warnings will be
-   --  posted later by Check_References. The reason we do things that
-   --  way is that if there are no assignments anywhere, we prefer to flag
-   --  the entity, rather than a reference to it. Note that for the purposes
-   --  of this routine, a type conversion or qualified expression whose
-   --  expression is an entity is also processed. The reason that we do not
-   --  process these at the point of occurrence is that both these constructs
-   --  can occur in non-reference positions (e.g. as out parameters).
+   --  Never_Set_In_Source set. If so, the Unset_Reference field is set if it
+   --  is not the first occurrence. No warning is posted, instead warnings will
+   --  be posted later by Check_References. The reason we do things that way is
+   --  that if there are no assignments anywhere, we prefer to flag the entity,
+   --  rather than a reference to it. Note that for the purposes of this
+   --  routine, a type conversion or qualified expression whose expression is
+   --  an entity is also processed. The reason that we do not process these
+   --  at the point of occurrence is that both these constructs can occur in
+   --  non-reference positions (e.g. as out parameters).
 
procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit);
--  This routine performs two kinds of checks. It checks that all with'ed

[Ada] Reorder processing of default expressions to avoid repeated calls

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup related to improved detection of uninitialised objects;
semantics is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch6.adb (Process_Formals): Avoid repeated calls to
Expression.diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -12985,10 +12985,10 @@ package body Sem_Ch6 is
  Set_Formal_Mode (Formal);
 
  if Ekind (Formal) = E_In_Parameter then
-Set_Default_Value (Formal, Expression (Param_Spec));
+Default := Expression (Param_Spec);
 
-if Present (Expression (Param_Spec)) then
-   Default := Expression (Param_Spec);
+if Present (Default) then
+   Set_Default_Value (Formal, Default);
 
if Is_Scalar_Type (Etype (Default)) then
   if Nkind (Parameter_Type (Param_Spec)) /=

[Ada] Fix spurious error on object renaming with ghost type

[Pierre-Marie de Rodat via Gcc-patches]

Renaming of an object of ghost type leads to a spurious error.  Now
fixed.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* ghost.adb (Is_OK_Ghost_Context): Detect ghost type inside object
renaming.diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -508,7 +508,16 @@ package body Ghost is
elsif Nkind (Parent (Par)) in N_Generic_Instantiation
| N_Renaming_Declaration
| N_Generic_Renaming_Declaration
-   and then Par = Name (Parent (Par))
+ and then Par = Name (Parent (Par))
+   then
+  return True;
+
+   --  In the case of the renaming of a ghost object, the type
+   --  itself may be ghost.
+
+   elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration
+ and then (Par = Subtype_Mark (Parent (Par))
+ or else Par = Access_Definition (Parent (Par)))
then
   return True;
 

[Ada] Reuse Get_Pragma_Arg to handle pragma argument associations

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup related to looking at pragma Thread_Local_Storage.
Semantics is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Build_Init_Statements): Reuse Get_Pragma_Arg.
* exp_prag.adb (Arg_N): Likewise.diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -3319,11 +3319,9 @@ package body Exp_Ch3 is
 --  Pragma case
 
 if Nkind (Ritem) = N_Pragma then
-   Exp := First (Pragma_Argument_Associations (Ritem));
-
-   if Nkind (Exp) = N_Pragma_Argument_Association then
-  Exp := Expression (Exp);
-   end if;
+   Exp :=
+ Get_Pragma_Arg
+   (First (Pragma_Argument_Associations (Ritem)));
 
--  Conversion for Priority expression
 


diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -105,12 +105,10 @@ package body Exp_Prag is
  end if;
   end loop;
 
-  if Present (Arg)
-and then Nkind (Arg) = N_Pragma_Argument_Association
-  then
- return Expression (Arg);
+  if Present (Arg) then
+ return Get_Pragma_Arg (Arg);
   else
- return Arg;
+ return Empty;
   end if;
end Arg_N;
 

[Ada] Remove use of a global name buffer when locating a file

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup; semantics is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* osint.adb (Locate_File): Use Name_Find with a parameter and
not with a global buffer.diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -1904,10 +1904,8 @@ package body Osint is
 if Dir_Name'Length = 0 then
Found := N;
 else
-   Name_Len := Full_Name'Length - 1;
-   Name_Buffer (1 .. Name_Len) :=
- Full_Name (1 .. Full_Name'Last - 1);
-   Found := Name_Find;
+   Found :=
+ Name_Find (Full_Name (Full_Name'First .. Full_Name'Last - 1));
 end if;
  end if;
   end;

[Ada] Remove repeated setting of Never_Set_In_Source

[Pierre-Marie de Rodat via Gcc-patches]

Formal parameters have their flag Never_Set_In_Source set at the
beginning of Process_Formals routine (regardless of the parameter mode).
There is no need to set it again when Process_Formals calls
Set_Formal_Mode (for parameters of mode IN OUT and OUT).

Code cleanup related to improved detection of uninitialised objects;
behaviour is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch6.adb (Set_Formal_Mode): Remove unnecessary setting of
Never_Set_In_Source.diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -13298,10 +13298,9 @@ package body Sem_Ch6 is
 Mutate_Ekind (Formal_Id, E_In_Out_Parameter);
 
  else
-Mutate_Ekind(Formal_Id, E_Out_Parameter);
-Set_Never_Set_In_Source (Formal_Id, True);
-Set_Is_True_Constant(Formal_Id, False);
-Set_Current_Value   (Formal_Id, Empty);
+Mutate_Ekind (Formal_Id, E_Out_Parameter);
+Set_Is_True_Constant (Formal_Id, False);
+Set_Current_Value(Formal_Id, Empty);
  end if;
 
   else

[Ada] Remove kludge for validity checks on Long_Float type

[Pierre-Marie de Rodat via Gcc-patches]

This patch reverts a fix for a spurious warning for validity checks on
type Long_Float. This fix was dubious (as it was only affecting
Long_Float and not Float) and apparently is no longer needed.

Cleanup related to improved detection of uninitialised scalar objects.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb (Note_Possible_Modification): Revert a
special-case for validity checks on Long_Float type.
* snames.ads-tmpl (Name_Attr_Long_Float): Remove name added
exclusively for the mentioned fix.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -11145,43 +11145,10 @@ package body Sem_Attr is
  =>
 --  Note possible modification if we have a variable
 
-if Is_Variable (P) then
-   declare
-  PN : constant Node_Id := Parent (N);
-  Nm : Node_Id;
-
-  Note : Boolean := True;
-  --  Skip this for the case of Unrestricted_Access occurring
-  --  in the context of a Valid check, since this otherwise
-  --  leads to a missed warning (the Valid check does not
-  --  really modify!) If this case, Note will be reset to
-  --  False.
-
-  --  Skip it as well if the type is an Access_To_Constant,
-  --  given that no use of the value can modify the prefix.
-
-   begin
-  if Attr_Id = Attribute_Unrestricted_Access
-and then Nkind (PN) = N_Function_Call
-  then
- Nm := Name (PN);
-
- if Nkind (Nm) = N_Expanded_Name
-   and then Chars (Nm) = Name_Valid
-   and then Nkind (Prefix (Nm)) = N_Identifier
-   and then Chars (Prefix (Nm)) = Name_Attr_Long_Float
- then
-Note := False;
- end if;
-
-  elsif Is_Access_Constant (Typ) then
- Note := False;
-  end if;
-
-  if Note then
- Note_Possible_Modification (P, Sure => False);
-  end if;
-   end;
+if Is_Variable (P)
+  and then not Is_Access_Constant (Typ)
+then
+   Note_Possible_Modification (P, Sure => False);
 end if;
 
 --  Case where prefix is an entity name


diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -776,7 +776,6 @@ package Snames is
Name_Allow  : constant Name_Id := N + $;
Name_Amount : constant Name_Id := N + $;
Name_As_Is  : constant Name_Id := N + $;
-   Name_Attr_Long_Float: constant Name_Id := N + $;
Name_Assertion  : constant Name_Id := N + $;
Name_Assertions : constant Name_Id := N + $;
Name_Attribute_Name : constant Name_Id := N + $;

[Ada] Couple of small cleanups for Cloned_Subtype

[Pierre-Marie de Rodat via Gcc-patches]

No functional changes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_util.adb (Make_Subtype_From_Expr): Do not set field to Empty.
* sem_util.adb (Visit_Itype): Remove ??? comment.diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -10213,8 +10213,8 @@ package body Exp_Util is
 
   elsif Is_Class_Wide_Type (Unc_Typ) then
  declare
-CW_Subtype : Entity_Id;
-EQ_Typ : Entity_Id := Empty;
+CW_Subtype : constant Entity_Id :=
+   New_Class_Wide_Subtype (Unc_Typ, E);
 
  begin
 --  A class-wide equivalent type is not needed on VM targets
@@ -10237,11 +10237,10 @@ package body Exp_Util is
   Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ;
end if;
 
-   EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
+   Set_Equivalent_Type
+ (CW_Subtype, Make_CW_Equivalent_Type (Unc_Typ, E));
 end if;
 
-CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
-Set_Equivalent_Type (CW_Subtype, EQ_Typ);
 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
 
 return New_Occurrence_Of (CW_Subtype, Loc);


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -25146,8 +25146,7 @@ package body Sem_Util is
  end if;
 
  --  If a record subtype is simply copied, the entity list will be
- --  shared. Thus cloned_Subtype must be set to indicate the sharing.
- --  ??? What does this do?
+ --  shared, so Cloned_Subtype must be set to indicate this.
 
  if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then
 Set_Cloned_Subtype (New_Itype, Itype);

[Ada] Warn about obsolete uses of renamed Ada 83 packages

[Pierre-Marie de Rodat via Gcc-patches]

Ada 83 packages like Unchecked_Conversion or Text_IO are obsolete since
Ada 95. GNAT now warns about their uses when warnings on obsolescent
featured (Annex J) is active.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* doc/gnat_ugn/building_executable_programs_with_gnat.rst
(Warning Message Control): Update description of switch -gnatwj.
* gnat_ugn.texi: Regenerate.
* sem_ch10.adb (Analyze_With_Clause): Warn on WITH clauses for
obsolete renamed units; in Ada 83 mode do not consider
predefined renamings to be obsolete.

gcc/testsuite/

* gnat.dg/renaming1.adb: Update WITH clause.
* gnat.dg/renaming1.ads: Likewise.
* gnat.dg/warn29.adb: Likewise.diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -3277,8 +3277,7 @@ of the pragma in the :title:`GNAT_Reference_manual`).
   If this warning option is activated, then warnings are generated for
   calls to subprograms marked with ``pragma Obsolescent`` and
   for use of features in Annex J of the Ada Reference Manual. In the
-  case of Annex J, not all features are flagged. In particular use
-  of the renamed packages (like ``Text_IO``) and use of package
+  case of Annex J, not all features are flagged. In particular, uses of package
   ``ASCII`` are not flagged, since these are very common and
   would generate many annoying positive warnings. The default is that
   such warnings are not generated.


diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -11383,8 +11383,7 @@ This switch disables warnings on overlapping actuals in a call.
 If this warning option is activated, then warnings are generated for
 calls to subprograms marked with @code{pragma Obsolescent} and
 for use of features in Annex J of the Ada Reference Manual. In the
-case of Annex J, not all features are flagged. In particular use
-of the renamed packages (like @code{Text_IO}) and use of package
+case of Annex J, not all features are flagged. In particular, uses of package
 @code{ASCII} are not flagged, since these are very common and
 would generate many annoying positive warnings. The default is that
 such warnings are not generated.


diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -2597,11 +2597,19 @@ package body Sem_Ch10 is
   --  Note: this is not quite right if the user defines one of these units
   --  himself, but that's a marginal case, and fixing it is hard ???
 
-  if Restriction_Check_Required (No_Obsolescent_Features) then
- if In_Predefined_Renaming (U) then
+  if Ada_Version >= Ada_95
+and then In_Predefined_Renaming (U)
+  then
+ if Restriction_Check_Required (No_Obsolescent_Features) then
 Check_Restriction (No_Obsolescent_Features, N);
 Restriction_Violation := True;
  end if;
+
+ if Warn_On_Obsolescent_Feature then
+Error_Msg_N
+  ("renamed predefined unit is an obsolescent feature "
+   & "(RM J.1)?j?", N);
+ end if;
   end if;
 
   --  Check No_Implementation_Units violation


diff --git a/gcc/testsuite/gnat.dg/renaming1.adb b/gcc/testsuite/gnat.dg/renaming1.adb
--- a/gcc/testsuite/gnat.dg/renaming1.adb
+++ b/gcc/testsuite/gnat.dg/renaming1.adb
@@ -1,12 +1,12 @@
 -- { dg-do compile}
 -- { dg-options "-gnatwa" }
 
-with Text_IO;
-use Text_IO;
+with Ada.Text_IO;
+use Ada.Text_IO;
 package body renaming1 is
-   procedure Fo (A : Text_IO.File_Access) is
+   procedure Fo (A : Ada.Text_IO.File_Access) is
begin
-  if A = Text_IO.Standard_Output then
+  if A = Ada.Text_IO.Standard_Output then
  null;
   end if;
end Fo;


diff --git a/gcc/testsuite/gnat.dg/renaming1.ads b/gcc/testsuite/gnat.dg/renaming1.ads
--- a/gcc/testsuite/gnat.dg/renaming1.ads
+++ b/gcc/testsuite/gnat.dg/renaming1.ads
@@ -1,4 +1,4 @@
-with Text_IO;
+with Ada.Text_IO;
 package renaming1 is
-   procedure Fo (A : Text_IO.File_Access);
+   procedure Fo (A : Ada.Text_IO.File_Access);
 end;


diff --git a/gcc/testsuite/gnat.dg/warn29.adb b/gcc/testsuite/gnat.dg/warn29.adb
--- a/gcc/testsuite/gnat.dg/warn29.adb
+++ b/gcc/testsuite/gnat.dg/warn29.adb
@@ -1,7 +1,7 @@
 --  { dg-do compile }
 --  { dg-options "-gnatwa" }
 
-with Text_IO; use Text_IO;
+with Ada.Text_IO; use Ada.Text_IO;
 
 package body Warn29 is
procedure P (X : T; Y : Integer) is

[Ada] Incorrect emptying of CUDA global subprograms

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects an error in the compiler whereby no
Corresponding_Spec was set for emptied CUDA global subprograms - leading
to a malformed tree.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gnat_cuda.adb (Empty_CUDA_Global_Subprogram): Set
Specification and Corresponding_Spec to match the original
Kernel_Body.diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb
--- a/gcc/ada/gnat_cuda.adb
+++ b/gcc/ada/gnat_cuda.adb
@@ -165,17 +165,20 @@ package body GNAT_CUDA is
 
   Kernel_Elm := First_Elmt (Kernels);
   while Present (Kernel_Elm) loop
- Kernel := Node (Kernel_Elm);
+ Kernel  := Node (Kernel_Elm);
  Kernel_Body := Subprogram_Body (Kernel);
- Loc := Sloc (Kernel_Body);
+ Loc := Sloc (Kernel_Body);
 
  Null_Body := Make_Subprogram_Body (Loc,
-   Specification  => Subprogram_Specification (Kernel),
+   Specification  => Specification (Kernel_Body),
Declarations   => New_List,
Handled_Statement_Sequence =>
  Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Make_Null_Statement (Loc;
 
+ Set_Corresponding_Spec (Null_Body,
+   Corresponding_Spec (Kernel_Body));
+
  Rewrite (Kernel_Body, Null_Body);
 
  Next_Elmt (Kernel_Elm);

[Ada] Remove explicit call to Make_Unchecked_Type_Conversion

[Pierre-Marie de Rodat via Gcc-patches]

Respect a comment in sinfo.ads, which says: "Unchecked type conversion
nodes should be created by calling Tbuild.Unchecked_Convert_To, rather
than by directly calling Nmake.Make_Unchecked_Type_Conversion."

No test appears to be affected by this change, so this is just a
cleanup.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch6.adb (Build_Static_Check_Helper_Call): Replace explicit
call to Make_Unchecked_Type_Conversion with a call to
Unchecked_Convert_To.
* tbuild.adb (Unchecked_Convert_To): Fix whitespace.diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -7578,9 +7578,7 @@ package body Exp_Ch6 is
   and then Etype (F) /= Etype (A)
 then
Append_To (Actuals,
- Make_Unchecked_Type_Conversion (Loc,
-   New_Occurrence_Of (Etype (F), Loc),
-   New_Copy_Tree (A)));
+ Unchecked_Convert_To (Etype (F), New_Copy_Tree (A)));
 else
Append_To (Actuals, New_Copy_Tree (A));
 end if;


diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -882,8 +882,8 @@ package body Tbuild is
   --  We don't really want to allow E_Void here, but existing code passes
   --  it.
 
-  Loc : constant Source_Ptr := Sloc (Expr);
-  Result  : Node_Id;
+  Loc: constant Source_Ptr := Sloc (Expr);
+  Result : Node_Id;
 
begin
   --  If the expression is already of the correct type, then nothing

[Ada] Fix incorrect itype sharing for case expression in limited type return

[Pierre-Marie de Rodat via Gcc-patches]

The compiler aborts with an internal error in gigi, but the problem is an
itype incorrectly shared between several branches of an if_statement that
has been created for a Build-In-Place return.

Three branches of this if_statement contain an allocator statement and
the latter two have been obtained as the result of calling New_Copy_Tree
on the first; now the initialization expression of the first had also been
obtained as the result of calling New_Copy_Tree on the original tree, and
these chained calls to New_Copy_Tree run afoul of an issue with the copy
of itypes after the rewrite of an aggregate as an expression with actions.

Fixing this issue looks quite delicate, so this fixes the incorrect sharing
by replacing the chained calls to New_Copy_Tree with repeated calls on the
original expression, which is more elegant in any case.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch3.adb (Make_Allocator_For_BIP_Return): New local function.
(Expand_N_Object_Declaration): Use it to build the three allocators
for a Build-In-Place return with an unconstrained type.  Update the
head comment after other recent changes.diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7980,16 +7980,11 @@ package body Exp_Ch3 is
 --  the value one, then the caller has passed access to an
 --  existing object for use as the return object. If the value
 --  is two, then the return object must be allocated on the
---  secondary stack. Otherwise, the object must be allocated in
---  a storage pool. We generate an if statement to test the
---  implicit allocation formal and initialize a local access
---  value appropriately, creating allocators in the secondary
---  stack and global heap cases. The special formal also exists
---  and must be tested when the function has a tagged result,
---  even when the result subtype is constrained, because in
---  general such functions can be called in dispatching contexts
---  and must be handled similarly to functions with a class-wide
---  result.
+--  secondary stack. If the value is three, then the return
+--  object must be allocated on the heap. Otherwise, the object
+--  must be allocated in a storage pool. We generate an if
+--  statement to test the BIP_Alloc_Form formal and initialize
+--  a local access value appropriately.
 
 if Needs_BIP_Alloc_Form (Func_Id) then
declare
@@ -8005,6 +8000,73 @@ package body Exp_Ch3 is
   Pool_Id  : constant Entity_Id :=
 Make_Temporary (Loc, 'P');
 
+  function Make_Allocator_For_BIP_Return return Node_Id;
+  --  Make an allocator for the BIP return being processed
+
+  ---
+  -- Make_Allocator_For_BIP_Return --
+  ---
+
+  function Make_Allocator_For_BIP_Return return Node_Id is
+ Alloc : Node_Id;
+
+  begin
+ if Present (Expr_Q)
+   and then not Is_Delayed_Aggregate (Expr_Q)
+   and then not No_Initialization (N)
+ then
+--  Always use the type of the expression for the
+--  qualified expression, rather than the result type.
+--  In general we cannot always use the result type
+--  for the allocator, because the expression might be
+--  of a specific type, such as in the case of an
+--  aggregate or even a nonlimited object when the
+--  result type is a limited class-wide interface type.
+
+Alloc :=
+  Make_Allocator (Loc,
+Expression =>
+  Make_Qualified_Expression (Loc,
+Subtype_Mark =>
+  New_Occurrence_Of (Etype (Expr_Q), Loc),
+Expression   => New_Copy_Tree (Expr_Q)));
+
+ else
+--  If the function returns a class-wide type we cannot
+--  use the return type for the allocator. Instead we
+--  use the type of the expression, which must be an
+--  aggregate of a definite type.
+
+if Is_Class_Wide_Type (Ret_Obj_Typ) then
+   Alloc :=
+ Make_Allocator (Loc,
+   Expression =>
+

[Ada] Restore accidentally removed part of a comment about unset references

[Pierre-Marie de Rodat via Gcc-patches]

Fix an unintentionally removed comment.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_res.adb (Resolve_Actuals): Restore first sentence of a
comment.diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4620,6 +4620,7 @@ package body Sem_Res is
  ("invalid use of untagged formal incomplete type", A);
 end if;
 
+--  For mode IN, if actual is an entity, and the type of the formal
 --  has warnings suppressed, then we reset Never_Set_In_Source for
 --  the calling entity. The reason for this is to catch cases like
 --  GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram

[Ada] Vxworks7* - Makefile.rtl rtp vs rtp-smp cleanup

[Pierre-Marie de Rodat via Gcc-patches]

Only smp runtimes are built for vxworks7*, even though the -smp suffix
is removed during install. Therefore, in general, the build macros for
the non-smp runtimes are superfluous except on the legacy ppc-vxworks6
target where both the smp and non-smp runtime are built.  Lastly, an
error message is added if a runtime build is commanded that doesn't
exist, rather then letting the build mysteriously fail.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* Makefile.rtl [arm,aarch64 vxworks7]: Remove rtp and kernel
build macros and set an error variable if needed.
[x86,x86_vxworks7]: Likewise.
[ppc,ppc64]: Set an error variable if needed.
(rts-err): New phony Makefile target.
(setup-rts): Depend on rts-err.diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -1124,6 +1124,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7%, $(target_cpu) $(targe
 
   EH_MECHANISM=-gcc
 
+  # The rtp and kernel sections must be retained for the sake of ppc-vx6
   ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),)
 LIBGNAT_TARGET_PAIRS += \
 s-vxwext.ads

[Ada] Cleanup use of local scalars in GNAT.Socket.Get_Address_Info

[Pierre-Marie de Rodat via Gcc-patches]

A cleanup opportunity spotted while working on improved detection of
uninitialised local scalar objects.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/g-socket.adb (Get_Address_Info): Reduce scope of the
Found variable; avoid repeated assignment inside the loop.diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb
--- a/gcc/ada/libgnat/g-socket.adb
+++ b/gcc/ada/libgnat/g-socket.adb
@@ -1036,7 +1036,6 @@ package body GNAT.Sockets is
 
   R : C.int;
   Iter  : Addrinfo_Access;
-  Found : Boolean;
 
   function To_Array return Address_Info_Array;
   --  Convert taken from OS addrinfo list A into Address_Info_Array
@@ -1046,8 +1045,6 @@ package body GNAT.Sockets is
   --
 
   function To_Array return Address_Info_Array is
- Result : Address_Info_Array (1 .. 8);
-
  procedure Unsupported;
  --  Calls Unknown callback if defiend
 
@@ -1066,6 +1063,9 @@ package body GNAT.Sockets is
 end if;
  end Unsupported;
 
+ Found  : Boolean;
+ Result : Address_Info_Array (1 .. 8);
+
   --  Start of processing for To_Array
 
   begin
@@ -1087,8 +1087,8 @@ package body GNAT.Sockets is
if Result (J).Addr.Family = Family_Unspec then
   Unsupported;
else
+  Found := False;
   for M in Modes'Range loop
- Found := False;
  if Modes (M) = Iter.ai_socktype then
 Result (J).Mode := M;
 Found := True;

[Ada] Remove old vxworks from Makefile.rtl - e500 port.

[Pierre-Marie de Rodat via Gcc-patches]

The powerpc e500 port has been LTS'd

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/system-vxworks7-e500-kernel.ads: Remove.
* libgnat/system-vxworks7-e500-rtp-smp.ads: Likewise.
* libgnat/system-vxworks7-e500-rtp.ads: Likewise.diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads /dev/null
deleted file mode 100644
--- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads
+++ /dev/null
@@ -1,160 +0,0 @@
---
---  --
---GNAT RUN-TIME COMPONENTS  --
---  --
---   S Y S T E M--
---  --
--- S p e c  --
---  (VxWorks 7 Kernel Version E500) --
---  --
---  Copyright (C) 1992-2022, Free Software Foundation, Inc. --
---  --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the  contents of the part following the private keyword. --
---  --
--- 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--
--- .  --
---  --
--- GNAT was originally developed  by the GNAT team at  New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc.  --
---  --
---
-
-package System is
-   pragma Pure;
-   --  Note that we take advantage of the implementation permission to make
-   --  this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-   --  2005, this is Pure in any case (AI-362).
-
-   pragma No_Elaboration_Code_All;
-   --  Allow the use of that restriction in units that WITH this unit
-
-   type Name is (SYSTEM_NAME_GNAT);
-   System_Name : constant Name := SYSTEM_NAME_GNAT;
-
-   --  System-Dependent Named Numbers
-
-   Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1);
-   Max_Int : constant :=  2 ** (Standard'Max_Integer_Size - 1) - 1;
-
-   Max_Binary_Modulus: constant := 2 ** Standard'Max_Integer_Size;
-   Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
-   Max_Base_Digits   : constant := Long_Long_Float'Digits;
-   Max_Digits: constant := Long_Long_Float'Digits;
-
-   Max_Mantissa  : constant := Standard'Max_Integer_Size - 1;
-   Fine_Delta: constant := 2.0 ** (-Max_Mantissa);
-
-   Tick  : constant := 1.0 / 60.0;
-
-   --  Storage-related Declarations
-
-   type Address is private;
-   pragma Preelaborable_Initialization (Address);
-   Null_Address : constant Address;
-
-   Storage_Unit : constant := 8;
-   Word_Size: constant := Standard'Word_Size;
-   Memory_Size  : constant := 2 ** Word_Size;
-
-   --  Address comparison
-
-   function "<"  (Left, Right : Address) return Boolean;
-   function "<=" (Left, Right : Address) return Boolean;
-   function ">"  (Left, Right : Address) return Boolean;
-   function ">=" (Left, Right : Address) return Boolean;
-   function "="  (Left, Right : Address) return Boolean;
-
-   pragma Import (Intrins

[Ada] Fix spurious error for aggregate with box component choice

[Pierre-Marie de Rodat via Gcc-patches]

It comes from the Volatile_Full_Access (or Atomic) aspect: the aggregate is
effectively analyzed/resolved twice and this does not work.  It is fixed by
calling Is_Full_Access_Aggregate before resolution.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_aggr.adb (Expand_Record_Aggregate): Do not call
Is_Full_Access_Aggregate here.
* freeze.ads (Is_Full_Access_Aggregate): Delete.
* freeze.adb (Is_Full_Access_Aggregate): Move to...
(Freeze_Entity): Do not call Is_Full_Access_Aggregate here.
* sem_aggr.adb (Is_Full_Access_Aggregate): ...here
(Resolve_Aggregate): Call Is_Full_Access_Aggregate here.diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -8779,19 +8779,10 @@ package body Exp_Aggr is
--  Start of processing for Expand_Record_Aggregate
 
begin
-  --  If the aggregate is to be assigned to a full access variable, we have
-  --  to prevent a piecemeal assignment even if the aggregate is to be
-  --  expanded. We create a temporary for the aggregate, and assign the
-  --  temporary instead, so that the back end can generate an atomic move
-  --  for it.
-
-  if Is_Full_Access_Aggregate (N) then
- return;
-
   --  No special management required for aggregates used to initialize
   --  statically allocated dispatch tables
 
-  elsif Is_Static_Dispatch_Table_Aggregate (N) then
+  if Is_Static_Dispatch_Table_Aggregate (N) then
  return;
 
   --  Case pattern aggregates need to remain as aggregates


diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -2309,67 +2309,6 @@ package body Freeze is
   end loop;
end Check_Unsigned_Type;
 
-   --
-   -- Is_Full_Access_Aggregate --
-   --
-
-   function Is_Full_Access_Aggregate (N : Node_Id) return Boolean is
-  Loc   : constant Source_Ptr := Sloc (N);
-  New_N : Node_Id;
-  Par   : Node_Id;
-  Temp  : Entity_Id;
-  Typ   : Entity_Id;
-
-   begin
-  Par := Parent (N);
-
-  --  Array may be qualified, so find outer context
-
-  if Nkind (Par) = N_Qualified_Expression then
- Par := Parent (Par);
-  end if;
-
-  if not Comes_From_Source (Par) then
- return False;
-  end if;
-
-  case Nkind (Par) is
- when N_Assignment_Statement =>
-Typ := Etype (Name (Par));
-
-if not Is_Full_Access (Typ)
-  and then not Is_Full_Access_Object (Name (Par))
-then
-   return False;
-end if;
-
- when N_Object_Declaration =>
-Typ := Etype (Defining_Identifier (Par));
-
-if not Is_Full_Access (Typ)
-  and then not Is_Full_Access (Defining_Identifier (Par))
-then
-   return False;
-end if;
-
- when others =>
-return False;
-  end case;
-
-  Temp := Make_Temporary (Loc, 'T', N);
-  New_N :=
-Make_Object_Declaration (Loc,
-  Defining_Identifier => Temp,
-  Constant_Present=> True,
-  Object_Definition   => New_Occurrence_Of (Typ, Loc),
-  Expression  => Relocate_Node (N));
-  Insert_Before (Par, New_N);
-  Analyze (New_N);
-
-  Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
-  return True;
-   end Is_Full_Access_Aggregate;
-
---
-- Explode_Initialization_Compound_Statement --
---
@@ -6447,20 +6386,6 @@ package body Freeze is
  then
 Set_Encoded_Interface_Name
   (E, Get_Default_External_Name (E));
-
- --  If entity is an atomic object appearing in a declaration and
- --  the expression is an aggregate, assign it to a temporary to
- --  ensure that the actual assignment is done atomically rather
- --  than component-wise (the assignment to the temp may be done
- --  component-wise, but that is harmless).
-
- elsif Is_Full_Access (E)
-   and then Nkind (Parent (E)) = N_Object_Declaration
-   and then Present (Expression (Parent (E)))
-   and then Nkind (Expression (Parent (E))) = N_Aggregate
-   and then Is_Full_Access_Aggregate (Expression (Parent (E)))
- then
-null;
  end if;
 
  --  Subprogram case


diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -177,15 +177,6 @@ package Freeze is
--  True when we are processing the body of a primitive with no previous
--  spec defined after R is frozen (see Check_Dispatching_Operation).
 
-   function Is_Full_Access_Aggregate (N : Node_Id) return Boolean;
-   --  If a full access object is initialized with an ag

[Ada] Missing error on tagged type conversion

[Pierre-Marie de Rodat via Gcc-patches]

The compiler does not report an error on a type conversion to/from a
tagged type whose parent type is an interface type and there is no
relationship between the source and target types. This bug has been
dormant since January/2016.

This patch also improves the text of errors reported on interface type
conversions suggesting how to fix these errors.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_res.adb (Resolve_Type_Conversion): Code cleanup since the
previous static check has been moved to Valid_Tagged_Conversion.
(Valid_Tagged_Conversion): Fix the code checking conversion
to/from interface types since incorrectly returns True when the
parent type of the operand type (or the target type) is an
interface type; add missing static checks on interface type
conversions.diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -31,6 +31,7 @@ with Debug_A;use Debug_A;
 with Einfo;  use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;use Einfo.Utils;
+with Elists; use Elists;
 with Errout; use Errout;
 with Expander;   use Expander;
 with Exp_Ch6;use Exp_Ch6;
@@ -12308,26 +12309,7 @@ package body Sem_Res is
 --  Conversion to interface type
 
 elsif Is_Interface (Target) then
-
-   --  Handle subtypes
-
-   if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then
-  Opnd := Etype (Opnd);
-   end if;
-
-   if Is_Class_Wide_Type (Opnd)
- or else Interface_Present_In_Ancestor
-   (Typ   => Opnd,
-Iface => Target)
-   then
-  Expand_Interface_Conversion (N);
-   else
-  Error_Msg_Name_1 := Chars (Etype (Target));
-  Error_Msg_Name_2 := Chars (Opnd);
-  Error_Msg_N
-("wrong interface conversion (% is not a progenitor "
- & "of %)", N);
-   end if;
+   Expand_Interface_Conversion (N);
 end if;
  end;
   end if;
@@ -13621,29 +13603,115 @@ package body Sem_Res is
   Conversion_Check (False,
 "downward conversion of tagged objects not allowed");
 
- --  Ada 2005 (AI-251): The conversion to/from interface types is
- --  always valid. The types involved may be class-wide (sub)types.
+ --  Ada 2005 (AI-251): A conversion is valid if the operand and target
+ --  types are both class-wide types and the specific type associated
+ --  with at least one of them is an interface type (RM 4.6 (23.1/2));
+ --  at run-time a check will verify the validity of this interface
+ --  type conversion.
 
- elsif Is_Interface (Etype (Base_Type (Target_Type)))
-   or else Is_Interface (Etype (Base_Type (Opnd_Type)))
+ elsif Is_Class_Wide_Type (Target_Type)
+and then Is_Class_Wide_Type (Opnd_Type)
+and then (Is_Interface (Target_Type)
+or else Is_Interface (Opnd_Type))
  then
 return True;
 
- --  If the operand is a class-wide type obtained through a limited_
- --  with clause, and the context includes the nonlimited view, use
- --  it to determine whether the conversion is legal.
+ --  Report errors
+
+ elsif Is_Class_Wide_Type (Target_Type)
+   and then Is_Interface (Target_Type)
+   and then not Is_Interface (Opnd_Type)
+   and then not Interface_Present_In_Ancestor
+  (Typ   => Opnd_Type,
+   Iface => Target_Type)
+ then
+Error_Msg_Name_1 := Chars (Etype (Target_Type));
+Error_Msg_Name_2 := Chars (Opnd_Type);
+Conversion_Error_N
+  ("wrong interface conversion (% is not a progenitor "
+   & "of %)", N);
+return False;
 
  elsif Is_Class_Wide_Type (Opnd_Type)
-   and then From_Limited_With (Opnd_Type)
-   and then Present (Non_Limited_View (Etype (Opnd_Type)))
-   and then Is_Interface (Non_Limited_View (Etype (Opnd_Type)))
+   and then Is_Interface (Opnd_Type)
+   and then not Is_Interface (Target_Type)
+   and then not Interface_Present_In_Ancestor
+  (Typ   => Target_Type,
+   Iface => Opnd_Type)
  then
-return True;
+Error_Msg_Name_1 := Chars (Etype (Opnd_Type));
+Error_Msg_Name_2 := Chars (Target_Type);
+Conversion_Error_N
+  ("wrong interface conversion (% is not a progenitor "
+   & "of %)", N);
 
- elsif Is_Access_Type (Opnd_Type)
-   and then Is_Interf

[Ada] Handle secondary stack memory allocations alignment

[Pierre-Marie de Rodat via Gcc-patches]

To accomodate cases where objects allocated on the secondary stack
needed a more constrained alignement than Standard'Maximum_Alignement,
the alignment for all allocations in the full runtime were forced on to
be aligned on Standard'Maximum_Alignement*2. This changes removes this
workaround and correctly handles the over-alignment in all runtimes.

This change modifies the SS_Allocate procedure to accept a new Alignment
parameter and to dynamically realign the pointer returned by the memory
allocation (Allocate_* functions or dedicated stack allocations for
zfp/cert).

It also simplifies the 0-sized allocations by not allocating any memory
if pointer is already correctly aligned (already the case in cert and
zfp runtimes).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/s-secsta.ads (SS_Allocate): Add new Alignment
parameter.
(Memory_Alignment): Remove.
* libgnat/s-secsta.adb (Align_Addr): New.
(SS_Allocate): Add new Alignment parameter. Realign pointer if
needed. Don't allocate anything for 0-sized allocations.
* gcc-interface/utils2.cc (build_call_alloc_dealloc_proc): Add
allocated object's alignment as last parameter to allocation
invocation.diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -2139,6 +2139,8 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
 			   Entity_Id gnat_proc, Entity_Id gnat_pool)
 {
   tree gnu_proc = gnat_to_gnu (gnat_proc);
+  tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
+
   tree gnu_call;
 
   /* A storage pool's underlying type is a record type for both predefined
@@ -2154,7 +2156,6 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
 
   tree gnu_pool = gnat_to_gnu (gnat_pool);
   tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
-  tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
 
   gnu_size = convert (gnu_size_type, gnu_size);
   gnu_align = convert (gnu_size_type, gnu_align);
@@ -2178,6 +2179,7 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
   tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
 
   gnu_size = convert (gnu_size_type, gnu_size);
+  gnu_align = convert (gnu_size_type, gnu_align);
 
   if (DECL_BUILT_IN_CLASS (gnu_proc) == BUILT_IN_FRONTEND
 	  && DECL_FE_FUNCTION_CODE (gnu_proc) == BUILT_IN_RETURN_SLOT)
@@ -2191,7 +2193,7 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
 
 	  gnu_call = DECL_RESULT (current_function_decl);
 
-	  /* The allocation has alreay been done by the caller so we check that
+	  /* The allocation has already been done by the caller so we check that
 	 we are not going to overflow the return slot.  */
 	  if (TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl)))
 	gnu_ret_size
@@ -2216,7 +2218,7 @@ build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
 	gnu_call = build_call_n_expr (gnu_proc, 2, gnu_obj, gnu_size);
 
   else
-	gnu_call = build_call_n_expr (gnu_proc, 1, gnu_size);
+	gnu_call = build_call_n_expr (gnu_proc, 2, gnu_size, gnu_align);
 }
 
   return gnu_call;
@@ -2334,7 +2336,7 @@ maybe_wrap_free (tree data_ptr, tree data_type)
 
 /* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
-   generate an allocator.
+   generate an allocation.
 
GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
object type, used to determine the to-be-honored address alignment.


diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -550,22 +550,52 @@ package body System.Secondary_Stack is
 
procedure SS_Allocate
  (Addr : out Address;
-  Storage_Size : Storage_Count)
+  Storage_Size : Storage_Count;
+  Alignment: SSE.Storage_Count := Standard'Maximum_Alignment)
is
+
   function Round_Up (Size : Storage_Count) return Memory_Size;
   pragma Inline (Round_Up);
   --  Round Size up to the nearest multiple of the maximum alignment
 
+  function Align_Addr (Addr : Address) return Address;
+  pragma Inline (Align_Addr);
+  --  Align Addr to the next multiple of Alignment
+
+  
+  -- Align_Addr --
+  
+
+  function Align_Addr (Addr : Address) return Address is
+ Int_Algn : constant Integer_Address := Integer_Address (Alignment);
+ Int_Addr : constant Integer_Address := To_Integer (Addr);
+  begin
+
+ --  L : Alignment
+ --  A : Standard'Maximum_Alignment
+
+ --   Addr
+ --  L | L   L
+ --  A--A--A--A--

[Ada] Improve code generated for aggregates of VFA type

[Pierre-Marie de Rodat via Gcc-patches]

This avoids using a full access for constants internally generated from
assignments of aggregates with a Volatile_Full_Access type.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gcc-interface/gigi.h (simple_constant_p): Declare.
* gcc-interface/decl.cc (gnat_to_gnu_entity) : Strip
the qualifiers from the type of a simple constant.
(simple_constant_p): New predicate.
* gcc-interface/trans.cc (node_is_atomic): Return true for objects
with atomic type except for simple constants.
(node_is_volatile_full_access): Return false for simple constants
with VFA type.diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -660,8 +660,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	 like variables.  */
   if (definition
 	  && !gnu_expr
-	  && No (Address_Clause (gnat_entity))
 	  && !No_Initialization (gnat_decl)
+	  && No (Address_Clause (gnat_entity))
 	  && No (gnat_renamed_obj))
 	{
 	  gnu_decl = error_mark_node;
@@ -781,6 +781,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 	if (kind == E_Loop_Parameter)
 	  gnu_type = get_base_type (gnu_type);
 
+	/* If this is a simple constant, strip the qualifiers from its type,
+	   since the constant represents only its value.  */
+	else if (simple_constant_p (gnat_entity))
+	  gnu_type = TYPE_MAIN_VARIANT (gnu_type);
+
 	/* Reject non-renamed objects whose type is an unconstrained array or
 	   any object whose type is a dummy type or void.  */
 	if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
@@ -9541,6 +9546,19 @@ promote_object_alignment (tree gnu_type, tree gnu_size, Entity_Id gnat_entity)
   return align;
 }
 
+/* Return whether GNAT_ENTITY is a simple constant, i.e. it represents only
+   its value and reading it has no side effects.  */
+
+bool
+simple_constant_p (Entity_Id gnat_entity)
+{
+  return Ekind (gnat_entity) == E_Constant
+	 && Present (Constant_Value (gnat_entity))
+	 && !No_Initialization (gnat_entity)
+	 && No (Address_Clause (gnat_entity))
+	 && No (Renamed_Object (gnat_entity));
+}
+
 /* Verify that TYPE is something we can implement atomically.  If not, issue
an error for GNAT_ENTITY.  COMPONENT_P is true if we are being called to
process a component type.  */


diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -998,6 +998,10 @@ extern Entity_Id get_debug_scope (Node_Id gnat_node, bool *is_subprogram);
should be synchronized with Exp_Dbug.Debug_Renaming_Declaration.  */
 extern bool can_materialize_object_renaming_p (Node_Id expr);
 
+/* Return whether GNAT_ENTITY is a simple constant, i.e. it represents only
+   its value and reading it has no side effects.  */
+extern bool simple_constant_p (Entity_Id gnat_entity);
+
 /* Return the size of TYPE, which must be a positive power of 2.  */
 extern unsigned int resolve_atomic_size (tree type);
 


diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -4111,9 +4111,11 @@ node_is_atomic (Node_Id gnat_node)
 case N_Identifier:
 case N_Expanded_Name:
   gnat_entity = Entity (gnat_node);
-  if (Ekind (gnat_entity) != E_Variable)
+  if (!Is_Object (gnat_entity))
 	break;
-  return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
+  return Is_Atomic (gnat_entity)
+	 || (Is_Atomic (Etype (gnat_entity))
+		 && !simple_constant_p (gnat_entity));
 
 case N_Selected_Component:
   return Is_Atomic (Etype (gnat_node))
@@ -4152,7 +4154,8 @@ node_is_volatile_full_access (Node_Id gnat_node)
   if (!Is_Object (gnat_entity))
 	break;
   return Is_Volatile_Full_Access (gnat_entity)
-	 || Is_Volatile_Full_Access (Etype (gnat_entity));
+	 || (Is_Volatile_Full_Access (Etype (gnat_entity))
+		 && !simple_constant_p (gnat_entity));
 
 case N_Selected_Component:
   return Is_Volatile_Full_Access (Etype (gnat_node))

[Ada] Small tweak to gnat_to_gnu_subprog_type

[Pierre-Marie de Rodat via Gcc-patches]

No functional changes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gcc-interface/decl.cc (gnat_to_gnu_subprog_type): Constify a
local variable and move a couple of others around.diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -5777,10 +5777,9 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 			  bool debug_info_p, tree *param_list)
 {
   const Entity_Kind kind = Ekind (gnat_subprog);
+  const Entity_Id gnat_return_type = Etype (gnat_subprog);
   const bool method_p = is_cplusplus_method (gnat_subprog);
   const bool variadic = IN (Convention (gnat_subprog), Convention_C_Variadic);
-  Entity_Id gnat_return_type = Etype (gnat_subprog);
-  Entity_Id gnat_param;
   tree gnu_type = present_gnu_tree (gnat_subprog)
 		  ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
   tree gnu_return_type;
@@ -5810,7 +5809,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
   bool return_by_direct_ref_p = false;
   bool return_by_invisi_ref_p = false;
   bool incomplete_profile_p = false;
-  int num;
 
   /* Look into the return type and get its associated GCC tree if it is not
  void, and then compute various flags for the subprogram type.  But make
@@ -5944,6 +5942,8 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 
   /* Loop over the parameters and get their associated GCC tree.  While doing
  this, build a copy-in copy-out structure if we need one.  */
+  Entity_Id gnat_param;
+  int num;
   for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), num++)

[Ada] Spurious non-callable warning on prefixed call in class condition

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects an error in the compiler whereby a function call in
prefix notation within a class condition causes a spurious error
claiming the name in the call is a non-callable entity when there exists
a type extension in the same unit extended with a component featuring
the same name as the function in question.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch4.adb (Analyze_Selected_Component): Add condition to
avoid interpreting derived type components as candidates for
selected components in preanalysis of inherited class
conditions.diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -5158,11 +5158,26 @@ package body Sem_Ch4 is
 
   elsif Is_Record_Type (Prefix_Type) then
 
- --  Find component with given name. In an instance, if the node is
- --  known as a prefixed call, do not examine components whose
- --  visibility may be accidental.
+ --  Find a component with the given name. If the node is a prefixed
+ --  call, do not examine components whose visibility may be
+ --  accidental.
 
- while Present (Comp) and then not Is_Prefixed_Call (N) loop
+ while Present (Comp)
+   and then not Is_Prefixed_Call (N)
+
+   --  When the selector has been resolved to a function then we may be
+   --  looking at a prefixed call which has been preanalyzed already as
+   --  part of a class condition. In such cases it is possible for a
+   --  derived type to declare a component which has the same name as
+   --  a primitive used in a parent's class condition.
+
+   --  Avoid seeing components as possible interpretations of the
+   --  selected component when this is true.
+
+   and then not (Inside_Class_Condition_Preanalysis
+  and then Present (Entity (Sel))
+  and then Ekind (Entity (Sel)) = E_Function)
+ loop
 if Chars (Comp) = Chars (Sel)
   and then Is_Visible_Component (Comp, N)
 then

[Ada] Indexing error when calling GNAT.Regpat.Match

[Pierre-Marie de Rodat via Gcc-patches]

This patch corrects an error in the compiler whereby a buffer sizing
error fails to get raised when compiling a regex expression with an
insufficiently sized Pattern_Matcher as the documentation indicated.
This, in turn, could lead to indexing errors when attempting to call
Match with the malformed regex program buffer.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/s-regpat.adb, libgnat/s-regpat.ads (Compile): Add a
new defaulted parameter Error_When_Too_Small to trigger an
error, if specified true, when Matcher is too small to hold the
compiled regex program.diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb
--- a/gcc/ada/libgnat/s-regpat.adb
+++ b/gcc/ada/libgnat/s-regpat.adb
@@ -359,10 +359,11 @@ package body System.Regpat is
-
 
procedure Compile
- (Matcher : out Pattern_Matcher;
-  Expression  : String;
-  Final_Code_Size : out Program_Size;
-  Flags   : Regexp_Flags := No_Flags)
+ (Matcher  : out Pattern_Matcher;
+  Expression   : String;
+  Final_Code_Size  : out Program_Size;
+  Flags: Regexp_Flags := No_Flags;
+  Error_When_Too_Small : Boolean := True)
is
   --  We can't allocate space until we know how big the compiled form
   --  will be, but we can't compile it (and thus know how big it is)
@@ -1994,6 +1995,12 @@ package body System.Regpat is
   end if;
 
   PM.Flags := Flags;
+
+  --  Raise the appropriate error when Matcher does not have enough space
+
+  if Error_When_Too_Small and then Matcher.Size < Final_Code_Size then
+ raise Expression_Error with "Pattern_Matcher is too small";
+  end if;
end Compile;
 
function Compile
@@ -2009,7 +2016,7 @@ package body System.Regpat is
   Size  : Program_Size;
 
begin
-  Compile (Dummy, Expression, Size, Flags);
+  Compile (Dummy, Expression, Size, Flags, Error_When_Too_Small => False);
 
   if Size <= Dummy.Size then
  return Pattern_Matcher'
@@ -2023,17 +2030,13 @@ package body System.Regpat is
 Program  =>
   Dummy.Program
 (Dummy.Program'First .. Dummy.Program'First + Size - 1));
-  else
- --  We have to recompile now that we know the size
- --  ??? Can we use Ada 2005's return construct ?
-
- declare
-Result : Pattern_Matcher (Size);
- begin
-Compile (Result, Expression, Size, Flags);
-return Result;
- end;
   end if;
+
+  return
+ Result : Pattern_Matcher (Size)
+  do
+ Compile (Result, Expression, Size, Flags);
+  end return;
end Compile;
 
procedure Compile


diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads
--- a/gcc/ada/libgnat/s-regpat.ads
+++ b/gcc/ada/libgnat/s-regpat.ads
@@ -403,10 +403,11 @@ package System.Regpat is
--  (e.g. case sensitivity,...).
 
procedure Compile
- (Matcher : out Pattern_Matcher;
-  Expression  : String;
-  Final_Code_Size : out Program_Size;
-  Flags   : Regexp_Flags := No_Flags);
+ (Matcher  : out Pattern_Matcher;
+  Expression   : String;
+  Final_Code_Size  : out Program_Size;
+  Flags: Regexp_Flags := No_Flags;
+  Error_When_Too_Small : Boolean := True);
--  Compile a regular expression into internal code
 
--  This procedure is significantly faster than the Compile function since
@@ -426,7 +427,25 @@ package System.Regpat is
--  expression.
--
--  This function raises Storage_Error if Matcher is too small to hold
-   --  the resulting code (i.e. Matcher.Size has too small a value).
+   --  the resulting code (i.e. Matcher.Size has too small a value) only when
+   --  the paramter Error_When_Too_Small is set to True. Otherwise, no error
+   --  will be raised and the required size will be placed in the
+   --  Final_Code_Size parameter.
+   --
+   --  Thus when Error_When_Too_Small is specified as false a check will need
+   --  to be made to ensure successful compilation - as in:
+   --
+   -- ...
+   -- Compile
+   --   (Matcher, Expr, Code_Size, Flags, Error_When_Too_Small => False);
+   --
+   -- if Matcher.Size < Code_Size then
+   --declare
+   --   New_Matcher : Pattern_Matcher (1..Code_Size);
+   --begin
+   --   Compile (New_Matcher, Expr, Code_Size, Flags);
+   --end;
+   -- end if;
--
--  Expression_Error is raised if the string Expression does not contain
--  a valid regular expression.

[Ada] Deferred constant considered as not preelaborable

[Pierre-Marie de Rodat via Gcc-patches]

Fix detection of non-preelaborable constructs for checking SPARK
elaboration rules, which was tagging deferred constant declarations as
not preelaborable.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_util.adb (Is_Non_Preelaborable_Construct): Fix for
deferred constants.diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -18952,8 +18952,9 @@ package body Sem_Util is
if Has_Init_Expression (Nod) then
   Visit (Expression (Nod));
 
-   elsif not Has_Preelaborable_Initialization
-   (Etype (Defining_Entity (Nod)))
+   elsif not Constant_Present (Nod)
+ and then not Has_Preelaborable_Initialization
+(Etype (Defining_Entity (Nod)))
then
   raise Non_Preelaborable;
end if;

[Ada] Simplify regular expression that matches 8 consecutive digits

[Pierre-Marie de Rodat via Gcc-patches]

Makefile cleanup; behaviour is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gcc-interface/Make-lang.in (ada/generated/gnatvsn.ads):
Simplify regular expression. The "interval expression",
i.e. \{8\} is part of the POSIX regular expressions, so it
should not be a problem for modern implementations of sed.diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -1158,7 +1158,7 @@ ada/generated/gnatvsn.ads: ada/gnatvsn.ads BASE-VER ada/GNAT_DATE
 	s=`cat $(srcdir)/BASE-VER | sed -e "s/\([0-9]*\)\.\([0-9]*\)\..*/-\1\2/g"`; \
 	d=`if test -f $(srcdir)/ada/GNAT_DATE; then \
cat $(srcdir)/ada/GNAT_DATE; else date +%Y%m%d; fi`; \
-	cat $< | sed -e "/Version/s/(\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*)/($$d$$s)/g" >$@
+	cat $< | sed -e "/Version/s/(\([0-9]\{8\}\).*)/($$d$$s)/g" >$@
 
 ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads
 	$(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION)

[Ada] Support ghost generic formal parameters

[Pierre-Marie de Rodat via Gcc-patches]

This adds support in GNAT for ghost generic formal parameters, as
included in SPARK RM 6.9.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* ghost.adb (Check_Ghost_Context): Delay checking for generic
associations.
(Check_Ghost_Context_In_Generic_Association): Perform ghost
checking in analyzed generic associations.
(Check_Ghost_Formal_Procedure_Or_Package): Check SPARK RM
6.9(13-14) for formal procedures and packages.
(Check_Ghost_Formal_Variable): Check SPARK RM 6.9(13-14) for
variables.
* ghost.ads: Declarations for the above.
* sem_ch12.adb (Analyze_Associations): Apply delayed checking
for generic associations.
(Analyze_Formal_Object_Declaration): Same.
(Analyze_Formal_Subprogram_Declaration): Same.
(Instantiate_Formal_Package): Same.
(Instantiate_Formal_Subprogram): Same.
(Instantiate_Object): Same.  Copy ghost aspect to newly declared
object for actual for IN formal object. Use new function
Get_Enclosing_Deep_Object to retrieve root object.
(Instantiate_Type): Copy ghost aspect to declared subtype for
actual for formal type.
* sem_prag.adb (Analyze_Pragma): Recognize new allowed
declarations.
* sem_util.adb (Copy_Ghost_Aspect): Copy the ghost aspect
between nodes.
(Get_Enclosing_Deep_Object): New function to return enclosing
deep object (or root for reachable part).
* sem_util.ads (Copy_Ghost_Aspect): Same.
(Get_Enclosing_Deep_Object): Same.
* libgnat/s-imageu.ads: Declare formal subprograms as ghost.
* libgnat/s-valuei.ads: Same.
* libgnat/s-valuti.ads: Same.diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -472,6 +472,13 @@ package body Ghost is
if Is_Ignored_Ghost_Node (Par) then
   return True;
 
+   --  It is not possible to check correct use of Ghost entities
+   --  in generic instantiations until after the generic has been
+   --  resolved. Postpone that verification to after resolution.
+
+   elsif Nkind (Par) = N_Generic_Association then
+  return True;
+
--  A reference to a Ghost entity can appear within an aspect
--  specification (SPARK RM 6.9(10)). The precise checking will
--  occur when analyzing the corresponding pragma. We make an
@@ -521,19 +528,6 @@ package body Ghost is
then
   return True;
 
-   --  In the context of an instantiation, accept currently Ghost
-   --  arguments for formal subprograms, as SPARK does not provide
-   --  a way to distinguish Ghost formal parameters from non-Ghost
-   --  ones. Illegal use of such arguments in a non-Ghost context
-   --  will lead to errors inside the instantiation.
-
-   elsif Nkind (Parent (Par)) = N_Generic_Association
- and then (Nkind (Par) in N_Has_Entity
-and then Present (Entity (Par))
-and then Is_Subprogram (Entity (Par)))
-   then
-  return True;
-
elsif Is_OK_Declaration (Par) then
   return True;
 
@@ -680,6 +674,128 @@ package body Ghost is
   end if;
end Check_Ghost_Context;
 
+   
+   -- Check_Ghost_Context_In_Generic_Association --
+   
+
+   procedure Check_Ghost_Context_In_Generic_Association
+ (Actual : Node_Id;
+  Formal : Entity_Id)
+   is
+  function Emit_Error_On_Ghost_Reference
+(N : Node_Id)
+ return Traverse_Result;
+  --  Determine wether N denotes a reference to a ghost entity, and if so
+  --  issue an error.
+
+  ---
+  -- Emit_Error_On_Ghost_Reference --
+  ---
+
+  function Emit_Error_On_Ghost_Reference
+(N : Node_Id)
+ return Traverse_Result
+  is
+  begin
+ if Is_Entity_Name (N)
+   and then Present (Entity (N))
+   and then Is_Ghost_Entity (Entity (N))
+ then
+Error_Msg_N ("ghost entity cannot appear in this context", N);
+Error_Msg_Sloc := Sloc (Formal);
+Error_Msg_NE ("\formal & was not declared as ghost #", N, Formal);
+return Abandon;
+ end if;
+
+ return OK;
+  end Emit_Error_On_Ghost_Reference;
+
+  procedure Check_Ghost_References is
+new Traverse_Proc (Emit_Error_On_Ghost_Reference);
+
+   --  Start of processing for Check_Ghost_Context_In_Generic_Association
+
+   begin
+  --  The context is ghost when it appears within a Ghost package or
+  --  subpr

[Ada] Remove excessive guard in detection of access-to-variable objects

[Pierre-Marie de Rodat via Gcc-patches]

It is safe to call Is_Access_Variable without calling
Is_Access_Object_Type before. Compiler cleanup only; semantics is
unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_util.adb (Is_Variable): Remove excessive guard.diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -21896,7 +21896,6 @@ package body Sem_Util is
   or else (K = E_Component
 and then not In_Protected_Function (E))
   or else (Present (Etype (E))
-and then Is_Access_Object_Type (Etype (E))
 and then Is_Access_Variable (Etype (E))
 and then Is_Dereferenced (N))
   or else K = E_Out_Parameter

[Ada] Warn about unreachable code after calls with No_Return

[Pierre-Marie de Rodat via Gcc-patches]

GNAT was already warning about unreachable code after raise/goto/exit
statements, but not after calls to procedures with No_Return. Now this
warning is extended.

Also, previously the warning was suppressed for unreachable RETURN after
RAISE statements. Now this suppression is narrowed to functions, because
only in function such a RETURN statement might be indeed needed (where
it is the only RETURN statement of a function).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch5.adb (Check_Unreachable_Code): Extend suppression to
calls with No_Return aspect, but narrow it to functions.
* sem_res.adb (Resolve_Call): Warn about unreachable code after
calls with No_Return.diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4418,12 +4418,20 @@ package body Sem_Ch5 is
  elsif Comes_From_Source (Nxt)
and then Is_Statement (Nxt)
  then
---  Special very annoying exception. If we have a return that
---  follows a raise, then we allow it without a warning, since
---  the Ada RM annoyingly requires a useless return here.
-
-if Nkind (Original_Node (N)) /= N_Raise_Statement
-  or else Nkind (Nxt) /= N_Simple_Return_Statement
+--  Special very annoying exception. Ada RM 6.5(5) annoyingly
+--  requires functions to have at least one return statement, so
+--  don't complain about a simple return that follows a raise or a
+--  call to procedure with No_Return.
+
+if not (Present (Current_Subprogram)
+and then Ekind (Current_Subprogram) = E_Function
+and then (Nkind (Original_Node (N)) = N_Raise_Statement
+or else
+  (Nkind (N) = N_Procedure_Call_Statement
+   and then Is_Entity_Name (Name (N))
+   and then Present (Entity (Name (N)))
+   and then No_Return (Entity (Name (N)
+and then Nkind (Nxt) = N_Simple_Return_Statement)
 then
--  The rather strange shenanigans with the warning message
--  here reflects the fact that Kill_Dead_Code is very good at


diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -62,6 +62,7 @@ with Sem_Case;   use Sem_Case;
 with Sem_Cat;use Sem_Cat;
 with Sem_Ch3;use Sem_Ch3;
 with Sem_Ch4;use Sem_Ch4;
+with Sem_Ch5;use Sem_Ch5;
 with Sem_Ch6;use Sem_Ch6;
 with Sem_Ch8;use Sem_Ch8;
 with Sem_Ch13;   use Sem_Ch13;
@@ -7193,6 +7194,14 @@ package body Sem_Res is
 
   Analyze_Dimension_Call (N, Nam);
 
+  --  Check unreachable code after calls to procedures with No_Return
+
+  if Ekind (Nam) = E_Procedure
+and then No_Return (Nam)
+  then
+ Check_Unreachable_Code (N);
+  end if;
+
   --  All done, evaluate call and deal with elaboration issues
 
   Eval_Call (N);

[Ada] Clean up scanner

[Pierre-Marie de Rodat via Gcc-patches]

This patch removes some obsolete code in the scanner and related files,
and corrects some comments. Tok_Special is used only by the
preprocessor, and uses only the two characters '#' and '$'.

It might be simpler to have a single flag indicating we're scanning for
preprocessing, instead of the Special_Characters array and the
End_Of_Line_Is_Token flag, but that's for another day.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* scans.ads: Fix obsolete comments about Tok_Special, and give
Special_Character a predicate assuring it is one of the two
characters used in preprocessing.
* scng.ads: Clean up comments.
* scng.adb: Clean up handling of Tok_Special.  Remove comment
about '@' (target_name), which doesn't seem very helpful.
Set_Special_Character will now blow up if given anything other
than '#' and '$', because of the predicate on Special_Character;
it's not clear why it used to say "when others => null;".
Remove Comment_Is_Token, which is not used.
* scn.ads: Remove commented-out use clause.  Remove redundant
comment.
* ali-util.adb: Use "is null" for do-nothing procedures.
* gprep.adb (Post_Scan): Use "is null".diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -42,15 +42,12 @@ package body ALI.Util is
--  empty, because we don't want to report any errors when computing
--  a source checksum.
 
-   procedure Post_Scan;
+   procedure Post_Scan is null;
 
-   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
-
-   procedure Error_Msg_S (Msg : String);
-
-   procedure Error_Msg_SC (Msg : String);
-
-   procedure Error_Msg_SP (Msg : String);
+   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is null;
+   procedure Error_Msg_S (Msg : String) is null;
+   procedure Error_Msg_SC (Msg : String) is null;
+   procedure Error_Msg_SP (Msg : String) is null;
 
--  Instantiation of Styleg, needed to instantiate Scng
 
@@ -85,47 +82,6 @@ package body ALI.Util is
   return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error;
end Checksums_Match;
 
-   ---
-   -- Error_Msg --
-   ---
-
-   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
-  pragma Warnings (Off, Msg);
-  pragma Warnings (Off, Flag_Location);
-   begin
-  null;
-   end Error_Msg;
-
-   -
-   -- Error_Msg_S --
-   -
-
-   procedure Error_Msg_S (Msg : String) is
-  pragma Warnings (Off, Msg);
-   begin
-  null;
-   end Error_Msg_S;
-
-   --
-   -- Error_Msg_SC --
-   --
-
-   procedure Error_Msg_SC (Msg : String) is
-  pragma Warnings (Off, Msg);
-   begin
-  null;
-   end Error_Msg_SC;
-
-   --
-   -- Error_Msg_SP --
-   --
-
-   procedure Error_Msg_SP (Msg : String) is
-  pragma Warnings (Off, Msg);
-   begin
-  null;
-   end Error_Msg_SP;
-
---
-- Get_File_Checksum --
---
@@ -192,15 +148,6 @@ package body ALI.Util is
   Interfaces.Reset;
end Initialize_ALI_Source;
 
-   ---
-   -- Post_Scan --
-   ---
-
-   procedure Post_Scan is
-   begin
-  null;
-   end Post_Scan;
-
--
-- Read_Withed_ALIs --
--


diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb
--- a/gcc/ada/gprep.adb
+++ b/gcc/ada/gprep.adb
@@ -93,8 +93,8 @@ package body GPrep is
procedure Display_Copyright;
--  Display the copyright notice
 
-   procedure Post_Scan;
-   --  Null procedure, needed by instantiation of Scng below
+   procedure Post_Scan is null;
+   --  Needed by instantiation of Scng below
 
package Scanner is new Scng
  (Post_Scan,
@@ -327,15 +327,6 @@ package body GPrep is
   New_Line (Outfile.all);
end New_EOL_To_Outfile;
 
-   ---
-   -- Post_Scan --
-   ---
-
-   procedure Post_Scan is
-   begin
-  null;
-   end Post_Scan;
-

-- Preprocess_Infile_Name --



diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -210,15 +210,11 @@ package Scans is
 
   Tok_End_Of_Line,
   --  Represents an end of line. Not used during normal compilation scans
-  --  where end of line is ignored. Active for preprocessor scanning and
-  --  also when scanning project files (where it is needed because of ???)
+  --  where end of line is ignored. Active for preprocessor scanning.
 
   Tok_Special,
-  --  AI12-0125-03 : target name as abbreviation for LHS
-
-  --  Otherwise used only in preprocessor scanning (to represent one of
-  --  the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
-  --  character value itself is stored in 

[Ada] Add new unbounded and indefinite formal doubly linked list

[Pierre-Marie de Rodat via Gcc-patches]

Before this patch, the only formal doubly linked lists were bounded and
definite. This means that it is necessary to provide their maximum
length or capacity at instantiation and that they can only be used with
definite element types.

The formal lists added by this patch are unbounded and indefinite.
Their length grows dynamically until Count_Type'Last. This makes them
easier to use but requires the use of dynamic allocation and controlled
types.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/a-cfidll.adb, libgnat/a-cfidll.ads: Implementation
files of the formal unbounded indefinite list.
* Makefile.rtl, impunit.adb: Take into account the add of the
new files.

patch.diff.gz
Description: application/gzip

[Ada] Add one more leading underscore to couple of exported symbols

[Pierre-Marie de Rodat via Gcc-patches]

For the sake of consistency with other runtime units.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/s-stchop.ads: Use a double underscore prefix for symbols.diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads
--- a/gcc/ada/libgnat/s-stchop.ads
+++ b/gcc/ada/libgnat/s-stchop.ads
@@ -72,7 +72,7 @@ package System.Stack_Checking.Operations is
 private
Cache : aliased Stack_Access := Null_Stack;
 
-   pragma Export (C, Cache, "_gnat_stack_cache");
-   pragma Export (C, Stack_Check, "_gnat_stack_check");
+   pragma Export (C, Cache, "__gnat_stack_cache");
+   pragma Export (C, Stack_Check, "__gnat_stack_check");
 
 end System.Stack_Checking.Operations;

[Ada] Ignore exceptions in task termination handlers

[Pierre-Marie de Rodat via Gcc-patches]

This patch fixes a bug in which if the environment task has a specific
termination handler, and that handler raises an exception, the handler
is called recursively, causing infinite recursion. The RM requires such
exceptions to be ignored.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnarl/s-solita.adb (Task_Termination_Handler_T): Ignore all
exceptions propagated by Specific_Handler.
* libgnarl/s-tassta.adb, libgnarl/s-taskin.ads: Minor.diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb
--- a/gcc/ada/libgnarl/s-solita.adb
+++ b/gcc/ada/libgnarl/s-solita.adb
@@ -188,7 +188,14 @@ package body System.Soft_Links.Tasking is
   --  fall-back handler applies only to the dependent tasks of the task".
 
   if Self_Id.Common.Specific_Handler /= null then
- Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
+ begin
+Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
+ exception
+--  RM-C.7.3(16) requires all exceptions raised here to be ignored
+
+when others =>
+   null;
+ end;
   end if;
end Task_Termination_Handler_T;
 


diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads
--- a/gcc/ada/libgnarl/s-taskin.ads
+++ b/gcc/ada/libgnarl/s-taskin.ads
@@ -1168,7 +1168,7 @@ package System.Tasking is
   --
   --  Protection: Self.L. Once a task has set Self.Stage to Completing, it
   --  has exclusive access to this field.
-   end record;
+   end record; -- Ada_Task_Control_Block
 

-- Initialization --


diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb
--- a/gcc/ada/libgnarl/s-tassta.adb
+++ b/gcc/ada/libgnarl/s-tassta.adb
@@ -1307,10 +1307,8 @@ package body System.Tasking.Stages is
   if TH /= null then
  begin
 TH.all (Cause, Self_ID, EO);
-
  exception
-
---  RM-C.7.3 requires all exceptions raised here to be ignored
+--  RM-C.7.3(16) requires all exceptions raised here to be ignored
 
 when others =>
null;

[Ada] Fix missing Overflow and Range checks

[Pierre-Marie de Rodat via Gcc-patches]

While doing Preanalysis (as is the case during ghost code handling),
some range and/or overflow checks can be saved (see Saved_Checks in
checks.adb) and later one omitted as they would be redundant (see
Find_Check in checks.adb). In the case of ghost code, the node being
Preanalyzed is a temporary copy that is discarded, so its corresponding
check is not expanded later. The node that gets expanded later is not
having any checks expanded as it is wrongly assumed it has already been
done before.

As is already the case in Preanalyze_And_Resolve, this change suppresses
all checks during Preanalyze except for GNATprove mode.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem.adb (Preanalyze): Suppress checks when not in GNATprove
mode.
* sem_res.adb (Preanalyze_And_Resolve): Add cross reference in
comment to above procedure.
* sinfo.ads: Typo fix in comment.diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -1338,7 +1338,15 @@ package body Sem is
   Full_Analysis := False;
   Expander_Mode_Save_And_Set (False);
 
-  Analyze (N);
+  --  See comment in sem_res.adb for Preanalyze_And_Resolve
+
+  if GNATprove_Mode
+or else Nkind (Parent (N)) = N_Simple_Return_Statement
+  then
+ Analyze (N);
+  else
+ Analyze (N, Suppress => All_Checks);
+  end if;
 
   Expander_Mode_Restore;
   Full_Analysis := Save_Full_Analysis;


diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2046,16 +2046,18 @@ package body Sem_Res is
   Full_Analysis := False;
   Expander_Mode_Save_And_Set (False);
 
+  --  See also Preanalyze_And_Resolve in sem.adb for similar handling
+
   --  Normally, we suppress all checks for this preanalysis. There is no
   --  point in processing them now, since they will be applied properly
   --  and in the proper location when the default expressions reanalyzed
   --  and reexpanded later on. We will also have more information at that
   --  point for possible suppression of individual checks.
 
-  --  However, in SPARK mode, most expansion is suppressed, and this
-  --  later reanalysis and reexpansion may not occur. SPARK mode does
+  --  However, in GNATprove mode, most expansion is suppressed, and this
+  --  later reanalysis and reexpansion may not occur. GNATprove mode does
   --  require the setting of checking flags for proof purposes, so we
-  --  do the SPARK preanalysis without suppressing checks.
+  --  do the GNATprove preanalysis without suppressing checks.
 
   --  This special handling for SPARK mode is required for example in the
   --  case of Ada 2012 constructs such as quantified expressions, which are


diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -554,9 +554,9 @@ package Sinfo is
--  The tree after this light expansion should be fully analyzed
--  semantically, which sometimes requires the insertion of semantic
--  preanalysis, for example for subprogram contracts and pragma
-   --  check/assert. In particular, all expression must have their proper type,
-   --  and semantic links should be set between tree nodes (partial to full
-   --  view, etc.) Some kinds of nodes should be either absent, or can be
+   --  check/assert. In particular, all expressions must have their proper
+   --  type, and semantic links should be set between tree nodes (partial to
+   --  full view, etc.). Some kinds of nodes should be either absent, or can be
--  ignored by the formal verification backend:
 
--  N_Object_Renaming_Declaration: can be ignored safely

[Ada] Proper freezing for dispatching expression functions.

[Pierre-Marie de Rodat via Gcc-patches]

In the case of an expression function that is a primitive function of a
tagged type, freezing the tagged type needs to freeze the function (and
its return expression). A bug in this area could result in incorrect
behavior both at compile time and at run time. At compile time, freezing
rule violations could go undetected so that an illegal program could be
incorrectly accepted. At run time, a dispatching call to the primitive
function could end up dispatching through a not-yet-initialized slot in
the dispatch table, typically (although not always) resulting in a
segmentation fault.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* freeze.adb (Check_Expression_Function.Find_Constant): Add a
check that a type that is referenced as the prefix of an
attribute is fully declared.
(Freeze_And_Append): Do not freeze the profile when freezing an
expression function.
(Freeze_Entity): When a tagged type is frozen, also freeze any
primitive operations of the type that are expression functions.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not prevent
freezing associated with an expression function body if the
function is a dispatching op.diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1470,6 +1470,10 @@ package body Freeze is
 if Is_Entity_Name (Prefix (Nod))
   and then Is_Type (Entity (Prefix (Nod)))
 then
+   if Expander_Active then
+  Check_Fully_Declared (Entity (Prefix (Nod)), N);
+   end if;
+
Freeze_Before (N, Entity (Prefix (Nod)));
 end if;
  end if;
@@ -2632,7 +2636,13 @@ package body Freeze is
   N  : Node_Id;
   Result : in out List_Id)
is
-  L : constant List_Id := Freeze_Entity (Ent, N);
+  --  Freezing an Expression_Function does not freeze its profile:
+  --  the formals will have been frozen otherwise before the E_F
+  --  can be called.
+
+  L : constant List_Id :=
+Freeze_Entity
+  (Ent, N, Do_Freeze_Profile => not Is_Expression_Function (Ent));
begin
   if Is_Non_Empty_List (L) then
  if Result = No_List then
@@ -7807,11 +7817,37 @@ package body Freeze is
  --  type itself is frozen, because the class-wide type refers to the
  --  tagged type which generates the class.
 
+ --  For a tagged type, freeze explicitly those primitive operations
+ --  that are expression functions, which otherwise have no clear
+ --  freeze point: these have to be frozen before the dispatch table
+ --  for the type is built, and before any explicit call to the
+ --  primitive, which would otherwise be the freeze point for it.
+
  if Is_Tagged_Type (E)
and then not Is_Class_Wide_Type (E)
and then Present (Class_Wide_Type (E))
  then
 Freeze_And_Append (Class_Wide_Type (E), N, Result);
+
+declare
+   Ops  : constant Elist_Id := Primitive_Operations (E);
+
+   Elmt : Elmt_Id;
+   Subp : Entity_Id;
+
+begin
+   if Ops /= No_Elist  then
+  Elmt := First_Elmt (Ops);
+  while Present (Elmt) loop
+ Subp := Node (Elmt);
+ if Is_Expression_Function (Subp) then
+Freeze_And_Append (Subp, N, Result);
+ end if;
+
+ Next_Elmt (Elmt);
+  end loop;
+   end if;
+end;
  end if;
   end if;
 


diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4508,7 +4508,16 @@ package body Sem_Ch6 is
 --  This also needs to be done in the case of an ignored Ghost
 --  expression function, where the expander isn't active.
 
-Set_Is_Frozen (Spec_Id);
+--  A further complication arises if the expression function is
+--  a primitive operation of a tagged type: in that case the
+--  function entity must be frozen before the dispatch table for
+--  the type is constructed, so it will be frozen like other local
+--  entities, at the end of the current scope.
+
+if not Is_Dispatching_Operation (Spec_Id) then
+   Set_Is_Frozen (Spec_Id);
+end if;
+
 Mask_Types := Mask_Unfrozen_Types (Spec_Id);
 
  elsif not Is_Frozen (Spec_Id)

[Ada] Fix spurious warning on unreferenced internal generic instance

[Pierre-Marie de Rodat via Gcc-patches]

This patch removes a spurious warning, saying that an internal entity of
a generic formal package is unreferenced. The immediate cause of this
warning is that the internal entity is explicitly flagged as coming from
source.

The explicit flagging was added decades ago to fix a missing
cross-reference in the ALI file. Apparently these days the
cross-references work fine without this flag.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch12.adb (Analyze_Package_Instantiation): Remove dubious
call to Set_Comes_From_Source.diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -4297,7 +4297,6 @@ package body Sem_Ch12 is
 
   if Nkind (N) = N_Package_Instantiation then
  Act_Decl_Id := New_Copy (Defining_Entity (N));
- Set_Comes_From_Source (Act_Decl_Id, True);
 
  if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
 Act_Decl_Name :=

[Ada] Remove out-of-range warning in unreachable code

[Pierre-Marie de Rodat via Gcc-patches]

This patch removes a warning in examples like this:

if cond then
   return; -- or other jump
end if;
X := ...; -- where the value is out of range

where cond is known at compile time. It could, for example, be a generic
formal parameter that is known to be True in some instances.

As a side effect, this patch adds new warnings about unreachable code.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* gnatls.adb (Output_License_Information): Remove pragma
No_Return; call sites deal with Exit_Program.
* libgnat/g-socthi.adb (C_Connect): Suppress warning about
unreachable code.
* sem_ch5.adb (Check_Unreachable_Code): Special-case if
statements with static conditions.  If we remove unreachable
code (including the return statement) from a function, add
"raise Program_Error", so we won't warn about missing returns.
Remove Original_Node in test for N_Raise_Statement; it's not
needed.  Remove test for CodePeer_Mode; if Operating_Mode =
Generate_Code, then CodePeer_Mode can't be True.  Misc cleanup.
Do not reuse Nxt variable for unrelated purpose (the usage in
the Kill_Dead_Code loop is entirely local to the loop).
* sem_ch6.adb: Add check for Is_Transfer. Misc cleanup.
* sem_prag.adb: Minor.
* sem_res.adb: Minor.
* sem_util.adb: Minor cleanup.
(Is_Trivial_Boolean): Move to nonnested place, so it can be
called from elsewhere.
(Is_Static_Constant_Boolean): New function.
* sem_util.ads (Is_Trivial_Boolean): Export.
(Is_Static_Constant_Boolean): New function.diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -189,7 +189,6 @@ procedure Gnatls is
--  Print usage message
 
procedure Output_License_Information;
-   pragma No_Return (Output_License_Information);
--  Output license statement, and if not found, output reference to COPYING
 
function Image (Restriction : Restriction_Id) return String;
@@ -894,8 +893,6 @@ procedure Gnatls is
  & " for license terms.");
 Write_Eol;
   end case;
-
-  Exit_Program (E_Success);
end Output_License_Information;
 
---


diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb
--- a/gcc/ada/libgnat/g-socthi.adb
+++ b/gcc/ada/libgnat/g-socthi.adb
@@ -187,7 +187,9 @@ package body GNAT.Sockets.Thin is
  return Res;
   end if;
 
-  declare
+  pragma Warnings (Off, "unreachable code");
+  declare -- unreachable if Thread_Blocking_IO is statically True
+ pragma Warnings (On, "unreachable code");
  WSet : aliased Fd_Set;
  Now  : aliased Timeval;
 


diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4425,7 +4425,7 @@ package body Sem_Ch5 is
 
 if not (Present (Current_Subprogram)
 and then Ekind (Current_Subprogram) = E_Function
-and then (Nkind (Original_Node (N)) = N_Raise_Statement
+and then (Nkind (N) in N_Raise_Statement
 or else
   (Nkind (N) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (N))
@@ -,39 +,59 @@ package body Sem_Ch5 is
--  unreachable code, since it is useless and we don't want
--  to generate junk warnings.
 
-   --  We skip this step if we are not in code generation mode
-   --  or CodePeer mode.
+   --  We skip this step if we are not in code generation mode.
 
--  This is the one case where we remove dead code in the
--  semantics as opposed to the expander, and we do not want
--  to remove code if we are not in code generation mode, since
--  this messes up the tree or loses useful information for
-   --  CodePeer.
+   --  analysis tools such as CodePeer.
 
--  Note that one might react by moving the whole circuit to
--  exp_ch5, but then we lose the warning in -gnatc mode.
 
-   if Operating_Mode = Generate_Code
- and then not CodePeer_Mode
-   then
+   if Operating_Mode = Generate_Code then
   loop
- Nxt := Next (N);
-
- --  Quit deleting when we have nothing more to delete
- --  or if we hit a label (since someone could transfer
- --  control to a label, so we should not delete it).
+ declare
+Del : constant Node_Id := Next (N);
+--  Node to be possibly deleted
+ begin
+--  Quit deleting

[Ada] Avoid namespace pollution for Next and Previous

[Pierre-Marie de Rodat via Gcc-patches]

This patch renames Next and Previous in a-convec.ads and other
containers to be _Next and _Previous, to avoid namespace pollution.  The
compiler now uses the leading-underscore names to look them up.

The scanner is changed to allow this.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Use _Next and
_Previous in the optimized expansion of "for ... of".  No longer
need to check parameter profiles for these, because the
leading-underscore names are unique.
* libgnat/a-convec.ads (_Next, _Previous): Renamings of Next and
Previous, to avoid namespace pollution.
* libgnat/a-cbdlli.ads, libgnat/a-cbhama.ads,
libgnat/a-cbhase.ads, libgnat/a-cbmutr.ads,
libgnat/a-cborma.ads, libgnat/a-cborse.ads,
libgnat/a-cdlili.ads, libgnat/a-cidlli.ads,
libgnat/a-cihama.ads, libgnat/a-cihase.ads,
libgnat/a-cimutr.ads, libgnat/a-ciorma.ads,
libgnat/a-ciorse.ads, libgnat/a-cobove.ads,
libgnat/a-cohama.ads, libgnat/a-cohase.ads,
libgnat/a-coinve.ads, libgnat/a-comutr.ads,
libgnat/a-coorma.ads, libgnat/a-coorse.ads: Likewise.  Also,
remove duplicated comments -- refer to one comment about _Next,
_Previous, Pseudo_Reference in libgnat/a-convec.ads. DRY.
* scng.adb (Scan): Allow leading underscores in identifiers in
the run-time library.
* snames.ads-tmpl (Name_uNext, Name_uPrevious): New names with
leading underscores.diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -4924,7 +4924,8 @@ package body Exp_Ch5 is
 
--  In the optimized case, we make use of these:
 
-   -- procedure Next (Position : in out Cursor); -- instead of Iter.Next
+   -- procedure _Next (Position : in out Cursor); -- instead of Iter.Next
+   --(or _Previous for reverse loops)
 
-- function Pseudo_Reference
--   (Container : aliased Vector'Class) return Reference_Control_Type;
@@ -4939,6 +4940,11 @@ package body Exp_Ch5 is
--  pollute the namespace for clients. The compiler has no trouble breaking
--  privacy to call things in the private part of an instance.)
 
+   --  Note that Next and Previous are renamed as _Next and _Previous with
+   --  leading underscores. Leading underscores are illegal in Ada, but we
+   --  allow them in the run-time library. This allows us to avoid polluting
+   --  the user-visible namespaces.
+
--  Source:
 
--  for X of My_Vector loop
@@ -4989,7 +4995,7 @@ package body Exp_Ch5 is
--  X.Count := X.Count + 1;
--  ...
--
-   --  Next (Cur); -- or Prev
+   --  _Next (Cur); -- or _Previous
--  --  This is instead of "Cur := Next (Iter, Cur);"
--  end;
--  --  No finalization here
@@ -5015,13 +5021,14 @@ package body Exp_Ch5 is
   Stats: List_Id := Statements (N);
   --  Maybe wrapped in a conditional if a filter is present
 
-  Cursor: Entity_Id;
-  Decl  : Node_Id;
-  Iter_Type : Entity_Id;
-  Iterator  : Entity_Id;
-  Name_Init : Name_Id;
-  Name_Step : Name_Id;
-  New_Loop  : Node_Id;
+  Cursor : Entity_Id;
+  Decl   : Node_Id;
+  Iter_Type  : Entity_Id;
+  Iterator   : Entity_Id;
+  Name_Init  : Name_Id;
+  Name_Step  : Name_Id;
+  Name_Fast_Step : Name_Id;
+  New_Loop   : Node_Id;
 
   Fast_Element_Access_Op : Entity_Id := Empty;
   Fast_Step_Op   : Entity_Id := Empty;
@@ -5049,9 +5056,11 @@ package body Exp_Ch5 is
   if Reverse_Present (I_Spec) then
  Name_Init := Name_Last;
  Name_Step := Name_Previous;
+ Name_Fast_Step := Name_uPrevious;
   else
  Name_Init := Name_First;
  Name_Step := Name_Next;
+ Name_Fast_Step := Name_uNext;
   end if;
 
   --  The type of the iterator is the return type of the Iterate function
@@ -5189,14 +5198,13 @@ package body Exp_Ch5 is
 
 Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
 
---  Find declarations needed for "for ... of" optimization
+--  Find declarations needed for "for ... of" optimization.
 --  These declarations come from GNAT sources or sources
 --  derived from them. User code may include additional
 --  overloadings with similar names, and we need to perforn
 --  some reasonable resolution to find the needed primitives.
---  It is unclear whether this mechanism is fragile if a user
---  makes arbitrary changes to the private part of a package
---  that supports iterators.
+--  Note that we use _Next or _Previous to avoid picking up
+--  some arbitrary user-defined Next or Previous.
 
  

[Ada] Fix buffer overrun for small string concatenation at -O0

[Pierre-Marie de Rodat via Gcc-patches]

The concatenation routines may read too much data on the source side when
the destination buffer is larger than the final result.  This change makes
sure that this does not happen any more and also removes obsolete stuff.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* rtsfind.ads (RE_Id): Remove RE_Str_Concat_Bounds_N values.
(RE_Unit_Table): Remove RE_Str_Concat_Bounds_N entries.
* libgnat/s-conca2.ads (Str_Concat_2): Adjust head comment.
(Str_Concat_Bounds_2): Delete.
* libgnat/s-conca2.adb (Str_Concat_2): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_2): Delete.
* libgnat/s-conca3.ads (Str_Concat_3): Adjust head comment.
(Str_Concat_Bounds_3): Delete.
* libgnat/s-conca3.adb (Str_Concat_3): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_3): Delete.
* libgnat/s-conca4.ads (Str_Concat_4): Adjust head comment.
(Str_Concat_Bounds_4): Delete.
* libgnat/s-conca4.adb (Str_Concat_4): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_4): Delete.
* libgnat/s-conca5.ads (Str_Concat_5): Adjust head comment.
(Str_Concat_Bounds_5): Delete.
* libgnat/s-conca5.adb (Str_Concat_5): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_5): Delete.
* libgnat/s-conca6.ads (Str_Concat_6): Adjust head comment.
(Str_Concat_Bounds_6): Delete.
* libgnat/s-conca6.adb (Str_Concat_6): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_6): Delete.
* libgnat/s-conca7.ads (Str_Concat_7): Adjust head comment.
(Str_Concat_Bounds_7): Delete.
* libgnat/s-conca7.adb (Str_Concat_7): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_7): Delete.
* libgnat/s-conca8.ads (Str_Concat_8): Adjust head comment.
(Str_Concat_Bounds_8): Delete.
* libgnat/s-conca8.adb (Str_Concat_8): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_8): Delete.
* libgnat/s-conca9.ads (Str_Concat_9): Adjust head comment.
(Str_Concat_Bounds_9): Delete.
* libgnat/s-conca9.adb (Str_Concat_9): Use the length of the last
input to size the last assignment.
(Str_Concat_Bounds_9): Delete.diff --git a/gcc/ada/libgnat/s-conca2.adb b/gcc/ada/libgnat/s-conca2.adb
--- a/gcc/ada/libgnat/s-conca2.adb
+++ b/gcc/ada/libgnat/s-conca2.adb
@@ -46,26 +46,8 @@ package body System.Concat_2 is
   R (F .. L) := S1;
 
   F := L + 1;
-  L := R'Last;
+  L := F + S2'Length - 1;
   R (F .. L) := S2;
end Str_Concat_2;
 
-   -
-   -- Str_Concat_Bounds_2 --
-   -
-
-   procedure Str_Concat_Bounds_2
- (Lo, Hi : out Natural;
-  S1, S2 : String)
-   is
-   begin
-  if S1 = "" then
- Lo := S2'First;
- Hi := S2'Last;
-  else
- Lo := S1'First;
- Hi := S1'Last + S2'Length;
-  end if;
-   end Str_Concat_Bounds_2;
-
 end System.Concat_2;


diff --git a/gcc/ada/libgnat/s-conca2.ads b/gcc/ada/libgnat/s-conca2.ads
--- a/gcc/ada/libgnat/s-conca2.ads
+++ b/gcc/ada/libgnat/s-conca2.ads
@@ -36,15 +36,8 @@ package System.Concat_2 is
 
procedure Str_Concat_2 (R : out String; S1, S2 : String);
--  Performs the operation R := S1 & S2. The bounds of R are known to be
-   --  correct (usually set by a call to the Str_Concat_Bounds_2 procedure
-   --  below), so no bounds checks are required, and it is known that none of
+   --  sufficient so no bound checks are required, and it is known that none of
--  the input operands overlaps R. No assumptions can be made about the
--  lower bounds of any of the operands.
 
-   procedure Str_Concat_Bounds_2
- (Lo, Hi : out Natural;
-  S1, S2 : String);
-   --  Assigns to Lo..Hi the bounds of the result of concatenating the two
-   --  given strings, following the rules in the RM regarding null operands.
-
 end System.Concat_2;


diff --git a/gcc/ada/libgnat/s-conca3.adb b/gcc/ada/libgnat/s-conca3.adb
--- a/gcc/ada/libgnat/s-conca3.adb
+++ b/gcc/ada/libgnat/s-conca3.adb
@@ -29,8 +29,6 @@
 --  --
 --
 
-with System.Concat_2;
-
 package body System.Concat_3 is
 
pragma Suppress (All_Checks);
@@ -52,25 +50,8 @@ package body System.Concat_3 is
   R (F .. L) := S2;
 
   F := L + 1;
-  L := R'Last;
+  L := F + S3'Length - 1;
   R (F .. L) := S3;
end Str_Concat_3;
 
-   -
-   -- Str_Concat_Bounds_3 --
-   -
-
-   procedure Str_Concat_Bounds_3
- (Lo, Hi : out Nat

[Ada] Ignore switches for controlling frontend warnings in GNATprove mode

[Pierre-Marie de Rodat via Gcc-patches]

In the special mode for GNATprove, ignore switches controlling frontend
warnings, like already done for the control of style checks warnings.
Also remove special handling of warning mode in Errout to make up for
the previous division of control between -gnatw (GNAT) and --warnings
(GNATprove).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* errout.adb (Record_Compilation_Errors): Remove global
variable.
(Compilation_Errors): Simplify.
(Initialize): Inline Reset_Warnings.
(Reset_Warnings): Remove.
* errout.ads (Reset_Warnings): Remove.
(Compilation_Errors): Update comment.
* gnat1drv.adb (Adjust_Global_Switches): Ignore all frontend
warnings in GNATprove mode, except regarding elaboration and
suspicious contracts.diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -64,13 +64,6 @@ package body Errout is
Finalize_Called : Boolean := False;
--  Set True if the Finalize routine has been called
 
-   Record_Compilation_Errors : Boolean := False;
-   --  Record that a compilation error was witnessed during a given phase of
-   --  analysis for gnat2why. This is needed as Warning_Mode is modified twice
-   --  in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
-   --  value for each phase of analysis separately. This is updated at each
-   --  call to Compilation_Errors.
-
Warn_On_Instance : Boolean;
--  Flag set true for warning message to be posted on instance
 
@@ -252,17 +245,8 @@ package body Errout is
begin
   if not Finalize_Called then
  raise Program_Error;
-
-  --  Record that a compilation error was witnessed during a given phase of
-  --  analysis for gnat2why. This is needed as Warning_Mode is modified
-  --  twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
-  --  suitable value for each phase of analysis separately.
-
   else
- Record_Compilation_Errors :=
-   Record_Compilation_Errors or else Erroutc.Compilation_Errors;
-
- return Record_Compilation_Errors;
+ return Erroutc.Compilation_Errors;
   end if;
end Compilation_Errors;
 
@@ -1914,7 +1898,10 @@ package body Errout is
 
   --  Reset counts for warnings
 
-  Reset_Warnings;
+  Warnings_Treated_As_Errors := 0;
+  Warnings_Detected := 0;
+  Warning_Info_Messages := 0;
+  Warnings_As_Errors_Count := 0;
 
   --  Initialize warnings tables
 
@@ -3414,18 +3401,6 @@ package body Errout is
   end loop;
end Remove_Warning_Messages;
 
-   
-   -- Reset_Warnings --
-   
-
-   procedure Reset_Warnings is
-   begin
-  Warnings_Treated_As_Errors := 0;
-  Warnings_Detected := 0;
-  Warning_Info_Messages := 0;
-  Warnings_As_Errors_Count := 0;
-   end Reset_Warnings;
-
--
-- Adjust_Name_Case --
--


diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -858,11 +858,6 @@ package Errout is
--  Remove warnings on all elements of a list (Calls Remove_Warning_Messages
--  on each element of the list, see above).
 
-   procedure Reset_Warnings;
-   --  Reset the counts related to warnings. This is used both to initialize
-   --  these counts and to reset them after each phase of analysis for a given
-   --  value of Opt.Warning_Mode in gnat2why.
-
procedure Set_Ignore_Errors (To : Boolean);
--  Following a call to this procedure with To=True, all error calls are
--  ignored. A call with To=False restores the default treatment in which
@@ -910,11 +905,10 @@ package Errout is
--  matching Warnings Off pragma preceding this one.
 
function Compilation_Errors return Boolean;
-   --  Returns True if errors have been detected, or warnings in -gnatwe (treat
-   --  warnings as errors) mode. Note that it is mandatory to call Finalize
-   --  before calling this routine. To account for changes to Warning_Mode in
-   --  gnat2why between phases, the past or current presence of an error is
-   --  recorded in a global variable at each call.
+   --  Returns True if errors have been detected, or warnings when they are
+   --  treated as errors, which corresponds to switch -gnatwe in the compiler,
+   --  and other switches in other tools. Note that it is mandatory to call
+   --  Finalize before calling this routine.
 
procedure Error_Msg_CRT (Feature : String; N : Node_Id);
--  Posts a non-fatal message on node N saying that the feature identified


diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -557,10 +557,14 @@ procedure Gnat1drv is
  Validity_Checks_On := False;
  Check_Validity_Of_Parameters := False;
 
- --  Turn off style check options since we are not interested in any
-  

[Ada] Refine heuristics for unreachable-code warnings

[Pierre-Marie de Rodat via Gcc-patches]

This patch refines the heuristics for when we warn about unreachable
code, to avoid common false alarms.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch5.adb (Check_Unreachable_Code): Refine heuristics.
* sem_util.ads, sem_util.adb (Is_Static_Constant_Name): Remove
this; instead we have a new function Is_Simple_Case in
Sem_Ch5.Check_Unreachable_Code.diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -4393,6 +4393,31 @@ package body Sem_Ch5 is

 
procedure Check_Unreachable_Code (N : Node_Id) is
+
+  function Is_Simple_Case (N : Node_Id) return Boolean;
+  --  N is the condition of an if statement. True if N is simple enough
+  --  that we should not set Unblocked_Exit_Count in the special case
+  --  below.
+
+  
+  -- Is_Simple_Case --
+  
+
+  function Is_Simple_Case (N : Node_Id) return Boolean is
+  begin
+ return
+Is_Trivial_Boolean (N)
+   or else
+(Comes_From_Source (N)
+   and then Is_Static_Expression (N)
+   and then Nkind (N) in N_Identifier | N_Expanded_Name
+   and then Ekind (Entity (N)) = E_Constant)
+   or else
+(not In_Instance
+   and then Nkind (Original_Node (N)) = N_Op_Not
+   and then Is_Simple_Case (Right_Opnd (Original_Node (N;
+  end Is_Simple_Case;
+
   Error_Node : Node_Id;
   Nxt: Node_Id;
   P  : Node_Id;
@@ -4574,8 +4599,7 @@ package body Sem_Ch5 is
   and then No (Else_Statements (P))
   and then Is_OK_Static_Expression (Condition (P))
   and then Is_True (Expr_Value (Condition (P)))
-  and then not Is_Trivial_Boolean (Condition (P))
-  and then not Is_Static_Constant_Name (Condition (P))
+  and then not Is_Simple_Case (Condition (P))
 then
pragma Assert (Unblocked_Exit_Count = 2);
Unblocked_Exit_Count := 0;


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -21532,18 +21532,6 @@ package body Sem_Util is
 and then Entity (N) in Standard_True | Standard_False;
end Is_Trivial_Boolean;
 
-   -
-   -- Is_Static_Constant_Name --
-   -
-
-   function Is_Static_Constant_Name (N : Node_Id) return Boolean is
-   begin
-  return Comes_From_Source (N)
-and then Is_Static_Expression (N)
-and then Nkind (N) in N_Identifier | N_Expanded_Name
-and then Ekind (Entity (N)) = E_Constant;
-   end Is_Static_Constant_Name;
-
--
-- Is_Unchecked_Conversion_Instance --
--


diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2485,9 +2485,6 @@ package Sem_Util is
--  Determine whether source node N denotes "True" or "False". Note that
--  this is not true for expressions that got folded to True or False.
 
-   function Is_Static_Constant_Name (N : Node_Id) return Boolean;
-   --  True if N is a name that statically denotes a static constant.
-
function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean;
--  Determine whether an arbitrary entity denotes an instance of function
--  Ada.Unchecked_Conversion.

[Ada] Vxworks7* - Makefile.rtl rtp vs rtp-smp cleanup - remove unused files

[Pierre-Marie de Rodat via Gcc-patches]

Only smp runtimes are built for vxworks7*, even though the -smp suffix
is removed during install. This change removes unused system packages
for rtp runtimes.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/system-vxworks7-ppc-rtp.ads: Remove
* libgnat/system-vxworks7-x86-rtp.ads: Likewise.diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads /dev/null
deleted file mode 100644
--- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads
+++ /dev/null
@@ -1,164 +0,0 @@
---
---  --
---GNAT RUN-TIME COMPONENTS  --
---  --
---   S Y S T E M--
---  --
--- S p e c  --
---  (VxWorks 7.x PPC RTP)   --
---  --
---  Copyright (C) 1992-2022, Free Software Foundation, Inc. --
---  --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the  contents of the part following the private keyword. --
---  --
--- 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--
--- .  --
---  --
--- GNAT was originally developed  by the GNAT team at  New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc.  --
---  --
---
-
---  This is the VxWorks version of this package for RTPs
-
-package System is
-   pragma Pure;
-   --  Note that we take advantage of the implementation permission to make
-   --  this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-   --  2005, this is Pure in any case (AI-362).
-
-   pragma No_Elaboration_Code_All;
-   --  Allow the use of that restriction in units that WITH this unit
-
-   type Name is (SYSTEM_NAME_GNAT);
-   System_Name : constant Name := SYSTEM_NAME_GNAT;
-
-   --  System-Dependent Named Numbers
-
-   Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1);
-   Max_Int : constant :=  2 ** (Standard'Max_Integer_Size - 1) - 1;
-
-   Max_Binary_Modulus: constant := 2 ** Standard'Max_Integer_Size;
-   Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
-   Max_Base_Digits   : constant := Long_Long_Float'Digits;
-   Max_Digits: constant := Long_Long_Float'Digits;
-
-   Max_Mantissa  : constant := Standard'Max_Integer_Size - 1;
-   Fine_Delta: constant := 2.0 ** (-Max_Mantissa);
-
-   Tick  : constant := 1.0 / 60.0;
-
-   --  Storage-related Declarations
-
-   type Address is private;
-   pragma Preelaborable_Initialization (Address);
-   Null_Address : constant Address;
-
-   Storage_Unit : constant := 8;
-   Word_Size: constant := Standard'Word_Size;
-   Memory_Size  : constant := 2 ** Word_Size;
-
-   --  Address comparison
-
-   function "<"  (Left, Right : Address) return Boolean;
-   function "<=" (Left, Right : Address) return Boolean;
-   function ">"  (Left, Right : Address) return Boolean;
-   function ">=" (Left, Right : Addre

[Ada] Accept aspect Yield on subprogram bodies acting as specs

[Pierre-Marie de Rodat via Gcc-patches]

A small fix for the aspect Yield defined in AI12-0279 for Ada 2022, to
accept aspect given for a subprogram body which acts as its own spec.

For example:

   procedure Switch with Yield => True is
   begin
  ...
   end Switch;

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch13.adb (Analyze_Aspect_Yield): Look at the entity kind,
not at the declaration kind.diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -2724,13 +2724,11 @@ package body Sem_Ch13 is
Expr_Value : Boolean := False;
 
 begin
-   --  Check valid declarations for 'Yield
+   --  Check valid entity for 'Yield
 
-   if Nkind (N) in N_Abstract_Subprogram_Declaration
- | N_Entry_Declaration
- | N_Generic_Subprogram_Declaration
- | N_Subprogram_Declaration
- | N_Formal_Subprogram_Declaration
+   if (Is_Subprogram (E)
+ or else Is_Generic_Subprogram (E)
+ or else Is_Entry (E))
  and then not Within_Protected_Type (E)
then
   null;

[Ada] Make it clear that gnatmake passes the ball to gprbuild if -P is set

[Pierre-Marie de Rodat via Gcc-patches]

Also move -P switch description to the top of the switches list.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* makeusg.adb,
doc/gnat_ugn/building_executable_programs_with_gnat.rst: Move -P
to the top of switches list and make it clear that gnatmake
passes the ball to gprbuild if -P is set.
* gnat_ugn.texi: Regenerate.diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -139,6 +139,17 @@ You may specify any of the following switches to ``gnatmake``:
   all other options.
 
 
+.. index:: -P  (gnatmake)
+
+:switch:`-P{project}`
+  Build GNAT project file ``project`` using GPRbuild. When this switch is
+  present, all other command-line switches are treated as GPRbuild switches
+  and not ``gnatmake`` switches.
+
+.. -- Comment:
+  :ref:`gnatmake_and_Project_Files`.
+
+
 .. index:: --GCC=compiler_name  (gnatmake)
 
 :switch:`--GCC={compiler_name}`
@@ -522,15 +533,6 @@ You may specify any of the following switches to ``gnatmake``:
 :switch:`-p`
   Same as :switch:`--create-missing-dirs`
 
-.. index:: -P  (gnatmake)
-
-:switch:`-P{project}`
-  Use project file ``project``. Only one such switch can be used.
-
-.. -- Comment:
-  :ref:`gnatmake_and_Project_Files`.
-
-
 .. index:: -q  (gnatmake)
 
 :switch:`-q`


diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,7 +21,7 @@
 
 @copying
 @quotation
-GNAT User's Guide for Native Platforms , Jun 24, 2022
+GNAT User's Guide for Native Platforms , Jul 11, 2022
 
 AdaCore
 
@@ -7120,6 +7120,21 @@ If @code{--version} was not used, display usage, then exit disregarding
 all other options.
 @end table
 
+@geindex -P (gnatmake)
+
+
+@table @asis
+
+@item @code{-P@emph{project}}
+
+Build GNAT project file @code{project} using GPRbuild. When this switch is
+present, all other command-line switches are treated as GPRbuild switches
+and not @code{gnatmake} switches.
+@end table
+
+@c -- Comment:
+@c :ref:`gnatmake_and_Project_Files`.
+
 @geindex --GCC=compiler_name (gnatmake)
 
 
@@ -7620,19 +7635,6 @@ This switch cannot be used when invoking @code{gnatmake} with several
 Same as @code{--create-missing-dirs}
 @end table
 
-@geindex -P (gnatmake)
-
-
-@table @asis
-
-@item @code{-P@emph{project}}
-
-Use project file @code{project}. Only one such switch can be used.
-@end table
-
-@c -- Comment:
-@c :ref:`gnatmake_and_Project_Files`.
-
 @geindex -q (gnatmake)
 
 


diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb
--- a/gcc/ada/makeusg.adb
+++ b/gcc/ada/makeusg.adb
@@ -54,6 +54,13 @@ begin
 
Display_Usage_Version_And_Help;
 
+   --  Line for -P
+
+   Write_Str ("  -Pproj   Build GNAT Project File proj using GPRbuild");
+   Write_Eol;
+   Write_Str ("   Treats all other switches as GPRbuild switches");
+   Write_Eol;
+
--  Line for -a
 
Write_Str ("  -a   Consider all files, even readonly ali files");
@@ -169,11 +176,6 @@ begin
Write_Str ("  -p   Create missing obj, lib and exec dirs");
Write_Eol;
 
-   --  Line for -P
-
-   Write_Str ("  -Pproj   Use GNAT Project File proj");
-   Write_Eol;
-
--  Line for -q
 
Write_Str ("  -q   Be quiet/terse");

[Ada] Warn on unset objects in packages with no bodies

[Pierre-Marie de Rodat via Gcc-patches]

Fix an inconsistency, where GNAT was warning about references to unset
objects inside generic packages with no bodies but not inside ordinary
packages with no bodies.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_ch7.adb (Analyze_Package_Declaration): Check references to
unset objects.

gcc/testsuite/

* gnat.dg/specs/discr5.ads: Expect new warnings.
* gnat.dg/specs/empty_variants.ads: Likewise.
* gnat.dg/specs/pack13.ads: Likewise.diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1253,6 +1253,13 @@ package body Sem_Ch7 is
   (Context  => N,
Is_Main_Unit => Parent (N) = Cunit (Main_Unit));
  end if;
+
+ --  Warn about references to unset objects, which is straightforward
+ --  for packages with no bodies. For packages with bodies this is more
+ --  complicated, because some of the objects might be set between spec
+ --  and body elaboration, in nested or child packages, etc.
+
+ Check_References (Id);
   end if;
 
   --  Set Body_Required indication on the compilation unit node


diff --git a/gcc/testsuite/gnat.dg/specs/discr5.ads b/gcc/testsuite/gnat.dg/specs/discr5.ads
--- a/gcc/testsuite/gnat.dg/specs/discr5.ads
+++ b/gcc/testsuite/gnat.dg/specs/discr5.ads
@@ -22,7 +22,7 @@ package Discr5 is
subtype Rt is R(True);
subtype Rf is R(False);
 
-   type R1 (D1 : Boolean) is new R (X) with record
+   type R1 (D1 : Boolean) is new R (X) with record -- { dg-warning "\"X\" may be referenced before it has a value" }
   FF : Float;
   case D1 is
  when True =>
@@ -38,7 +38,7 @@ package Discr5 is
subtype R1t is R1 (True);
subtype R1f is R1 (False);
 
-   type R2 (D2 : Boolean) is new R1 (Y) with record
+   type R2 (D2 : Boolean) is new R1 (Y) with record -- { dg-warning "\"Y\" may be referenced before it has a value" }
   FFF: System.Address;
   case D2 is
  when True =>
@@ -55,3 +55,4 @@ package Discr5 is
subtype R2f is R2 (False);
 
 end Discr5;
+


diff --git a/gcc/testsuite/gnat.dg/specs/empty_variants.ads b/gcc/testsuite/gnat.dg/specs/empty_variants.ads
--- a/gcc/testsuite/gnat.dg/specs/empty_variants.ads
+++ b/gcc/testsuite/gnat.dg/specs/empty_variants.ads
@@ -1,5 +1,4 @@
 --  { dg-do compile }
---  { dg-options "-gnatdF" }
 
 package Empty_Variants is

@@ -23,10 +22,11 @@ package Empty_Variants is

R : Rec;

-   I : Integer := R.I;
+   I : Integer := R.I; -- { dg-warning "\"R\.I\" may be referenced before it has a value" }
J : Integer := R.J;
K : Integer := R.K;
L : Integer := R.L;
M : Integer := R.L;
 
 end Empty_Variants;
+


diff --git a/gcc/testsuite/gnat.dg/specs/pack13.ads b/gcc/testsuite/gnat.dg/specs/pack13.ads
--- a/gcc/testsuite/gnat.dg/specs/pack13.ads
+++ b/gcc/testsuite/gnat.dg/specs/pack13.ads
@@ -20,6 +20,6 @@ package Pack13 is
 
   A : Arr;
 
-  package My_G is new G (Boolean, A(True).B);
+  package My_G is new G (Boolean, A(True).B); -- { dg-warning "\"A\" may be referenced before it has a value" }
 
 end Pack13;

[Ada] Suppress warning in g-socthi__vxworks.adb

[Pierre-Marie de Rodat via Gcc-patches]

Follow-on to previous change, which missed the vxworks version of this
package.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/g-socthi__vxworks.adb (C_Connect): Suppress new warning.diff --git a/gcc/ada/libgnat/g-socthi__vxworks.adb b/gcc/ada/libgnat/g-socthi__vxworks.adb
--- a/gcc/ada/libgnat/g-socthi__vxworks.adb
+++ b/gcc/ada/libgnat/g-socthi__vxworks.adb
@@ -190,7 +190,9 @@ package body GNAT.Sockets.Thin is
  return Res;
   end if;
 
-  declare
+  pragma Warnings (Off, "unreachable code");
+  declare -- unreachable if Thread_Blocking_IO is statically True
+ pragma Warnings (On, "unreachable code");
  WSet : aliased Fd_Set;
  Now  : aliased Timeval;
   begin

[Ada] Simplify rewriting of attributes into Boolean literals

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup; semantics is unaffected.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_attr.adb (Set_Boolean_Result): Simplify using
Boolean_Literals.diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12778,13 +12778,8 @@ package body Sem_Attr is

 
procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
-  Loc : constant Source_Ptr := Sloc (N);
begin
-  if B then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-  else
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
-  end if;
+  Rewrite (N, New_Occurrence_Of (Boolean_Literals (B), Sloc (N)));
end Set_Boolean_Result;
 

[Ada] Fix confusing error expression on an unknown restriction

[Pierre-Marie de Rodat via Gcc-patches]

When pragma Restriction is used with an unknown restriction identifier,
it is better to not process the restriction expression, as it will
likely produce confusing error message.

In particular, an odd message appeared when there was a typo in the
restriction identifier whose expression requires special processing
(e.g.  No_Dependence_On instead of No_Dependence).

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
Do not process expression of unknown restrictions.diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10792,13 +10792,15 @@ package body Sem_Prag is
 
 else
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
-   Analyze_And_Resolve (Expr, Any_Integer);
 
if R_Id not in All_Parameter_Restrictions then
   Error_Pragma_Arg
 ("invalid restriction parameter identifier", Arg);
+   end if;
+
+   Analyze_And_Resolve (Expr, Any_Integer);
 
-   elsif not Is_OK_Static_Expression (Expr) then
+   if not Is_OK_Static_Expression (Expr) then
   Flag_Non_Static_Expr
 ("value must be static expression!", Expr);
   raise Pragma_Exit;

[Ada] Annotate libraries with returning annotation

[Pierre-Marie de Rodat via Gcc-patches]

This patch annotates SPARK-annotated libraries with returning
annotations (Always_Return, Might_Not_Return) to remove the warnings
raised by GNATprove about missing annotations.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnarl/a-reatim.ads, libgnat/a-cfdlli.ads,
libgnat/a-cfhama.ads, libgnat/a-cfhase.ads,
libgnat/a-cfinse.ads, libgnat/a-cfinve.ads,
libgnat/a-cforma.ads, libgnat/a-cforse.ads,
libgnat/a-chahan.ads, libgnat/a-cofove.ads,
libgnat/a-cofuma.ads, libgnat/a-cofuse.ads,
libgnat/a-cofuve.ads, libgnat/a-nbnbin.ads,
libgnat/a-nbnbre.ads, libgnat/a-ngelfu.ads,
libgnat/a-nlelfu.ads, libgnat/a-nllefu.ads,
libgnat/a-nselfu.ads, libgnat/a-nuelfu.ads,
libgnat/a-strbou.ads, libgnat/a-strfix.ads,
libgnat/a-strmap.ads, libgnat/a-strunb.ads,
libgnat/a-strunb__shared.ads,  libgnat/a-strsea.ads,
libgnat/a-textio.ads, libgnat/a-tideio.ads,
libgnat/a-tienio.ads, libgnat/a-tifiio.ads,
libgnat/a-tiflio.ads, libgnat/a-tiinio.ads,
libgnat/a-timoio.ads, libgnat/i-c.ads, libgnat/interfac.ads,
libgnat/interfac__2020.ads, libgnat/s-atacco.ads,
libgnat/s-stoele.ads: Annotate packages and subprograms with
returning annotations.

patch.diff.gz
Description: application/gzip

[Ada] Ada 2020: Allow declarative items mixed with statements

[Pierre-Marie de Rodat via Gcc-patches]

This patch implements a syntactic language extension that allows
declarative items to appear in a sequence of statements.  For example:

for X in S'Range loop
Item : Character renames S (X);
Item := Transform (Item);
end loop;

Previously, declare/begin/end was required, which is just noise.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* par.adb (P_Declarative_Items): New function to parse a
sequence of declarative items.
(P_Sequence_Of_Statements): Add Handled flag, to indicate
whether to wrap the result in a block statement.
* par-ch3.adb (P_Declarative_Item): Rename P_Declarative_Items
to be P_Declarative_Item, because it really only parses a single
declarative item, and to avoid conflict with the new
P_Declarative_Items. Add In_Statements.  We keep the old
error-recovery mechanisms in place when In_Statements is False.
When True, we don't want to complain about statements, because
we are parsing a sequence of statements.
(P_Identifier_Declarations): If In_Statements, and we see what
looks like a statement, we no longer give an error. We return to
P_Sequence_Of_Statements with Done = True, so it can parse the
statement.
* par-ch5.adb (P_Sequence_Of_Statements): Call
P_Declarative_Items to parse declarative items that appear in
the statement list.  Remove error handling code that complained
about such items.  Check some errors conservatively.  Wrap the
result in a block statement when necessary.
* par-ch11.adb (P_Handled_Sequence_Of_Statements): Pass
Handled => True to P_Sequence_Of_Statements.
* types.ads (No, Present): New functions for querying
Source_Ptrs (equal, not equal No_Location).

patch.diff.gz
Description: application/gzip

[Ada] Don't check for misspelling of Not_A_Restriction_Id

[Pierre-Marie de Rodat via Gcc-patches]

When looking for a misspelling of a restriction identifier we should
ignore the Not_A_Restriction_Id literal, because it doesn't represent
any restriction.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
Fix range of iteration.diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10561,7 +10561,7 @@ package body Sem_Prag is
 
   --  Check for possible misspelling
 
-  for J in Restriction_Id loop
+  for J in All_Restrictions loop
  declare
 Rnm : constant String := Restriction_Id'Image (J);
 

[Ada] Fix inconsistent comment about expansion of exception declarations

[Pierre-Marie de Rodat via Gcc-patches]

Code cleanup.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* exp_ch11.adb (Expand_N_Exception_Declaration): Sync comment
with declaration in System.Standard_Library.diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -1136,7 +1136,7 @@ package body Exp_Ch11 is
   Set_Is_Statically_Allocated (Ex_Id);
 
   --  Create the aggregate list for type Standard.Exception_Type:
-  --  Handled_By_Other component: False
+  --  Not_Handled_By_Others component: False
 
   L := Empty_List;
   Append_To (L, New_Occurrence_Of (Standard_False, Loc));

[Ada] Fix 0-sized secondary stack allocations

[Pierre-Marie de Rodat via Gcc-patches]

The Has_Enough_Free_Memory was not correctly reporting a completely full
chunk in the case of a 0-sized allocation.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

* libgnat/s-secsta.adb (Has_Enough_Free_Memory): Check for full
chunk before computing the available size.diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -506,12 +506,17 @@ package body System.Secondary_Stack is
   Mem_Size : Memory_Size) return Boolean
is
begin
+  --  First check if the chunk is full (Byte is > Memory'Last in that
+  --  case), then check there is enough free memory.
+
   --  Byte - 1 denotes the last occupied byte. Subtracting that byte from
   --  the memory capacity of the chunk yields the size of the free memory
   --  within the chunk. The chunk can fit the request as long as the free
   --  memory is as big as the request.
 
-  return Chunk.Size - (Byte - 1) >= Mem_Size;
+  return Chunk.Memory'Last >= Byte
+and then Chunk.Size - (Byte - 1) >= Mem_Size;
+
end Has_Enough_Free_Memory;
 
--