Re: [Ada] Validity check failure with packed array and pragma

[Pierre-Marie de Rodat]

On 09/18/2017 12:02 PM, Eric Botcazou wrote:

You don't need this, just use:

--  { dg-options "-O -gnatn -gnatVa -gnatws" }

The -cargs/-margs trick is only needed for special switches like -dA.


That’s right, will do, thank you! Do I need to create a new ChangeLog 
entry in gcc/testsuite/ or is it fine if I just keep the current “New 
testcase.”?


--
Pierre-Marie de Rodat

[Ada] Crash on illegal current instance

[Pierre-Marie de Rodat]

If the type_mark of a qualified_expression refers to the current
instance of the type, do not crash; instead give a proper error
message. This is illegal by RM-8.6(17).

The following test should get an error:

current_instance_default.ads:2:54: current instance not allowed

package Current_Instance_Default is
   type Color is (Red, Orange) with Default_Value => Color'(Red); -- ERROR:
end Current_Instance_Default;

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

2017-09-18  Bob Duff  

* sem_ch4.adb (Analyze_Qualified_Expression): Give an error if the type
mark refers to the current instance. Set the type to Any_Type in that
case, to avoid later crashes.

Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 252907)
+++ sem_ch4.adb (working copy)
@@ -3930,6 +3930,23 @@
   Set_Etype (N, Any_Type);
   Find_Type (Mark);
   T := Entity (Mark);
+
+  if Nkind_In
+(Enclosing_Declaration (N),
+ N_Formal_Type_Declaration,
+ N_Full_Type_Declaration,
+ N_Incomplete_Type_Declaration,
+ N_Protected_Type_Declaration,
+ N_Private_Extension_Declaration,
+ N_Private_Type_Declaration,
+ N_Subtype_Declaration,
+ N_Task_Type_Declaration)
+and then T = Defining_Identifier (Enclosing_Declaration (N))
+  then
+ Error_Msg_N ("current instance not allowed", Mark);
+ T := Any_Type;
+  end if;
+
   Set_Etype (N, T);
 
   if T = Any_Type then

[Ada] Crash on mutable record component with box initialization

[Pierre-Marie de Rodat]

This patch fixes a compiler abort on a record declaration that includes a
mutable record component whose default value is an aggregate that includes
a box-initialized component whose value depends on a discriminant of the
component.

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

gcc/ada/

2017-09-18  Ed Schonberg  

* exp_ch3.adb (Replace_Discriminant_References): New procedure,
subsidiary of Build_Assignment, used to handle the initialization code
for a mutable record component whose default value is an aggregate that
sets the values of the discriminants of the components.

gcc/testsuite/

2017-09-18  Ed Schonberg  

* gnat.dg/default_variants.adb: New testcase.
Index: exp_ch3.adb
===
--- exp_ch3.adb (revision 252907)
+++ exp_ch3.adb (working copy)
@@ -1782,6 +1782,42 @@
  Lhs  : Node_Id;
  Res  : List_Id;
 
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+ --  Analysis of the aggregate has replaced discriminants by their
+ --  corresponding discriminals, but these are irrelevant when the
+ --  component has a mutable type and is initialized with an aggregate.
+ --  Instead, they must be replaced by the values supplied in the
+ --  aggregate, that will be assigned during the expansion of the
+ --  assignment.
+
+ ---
+ -- Replace_Discr_Ref --
+ ---
+
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+Val : Node_Id;
+ begin
+if Is_Entity_Name (N)
+  and then Present (Entity (N))
+  and then Is_Formal (Entity (N))
+  and then Present (Discriminal_Link (Entity (N)))
+then
+   Val :=
+  Make_Selected_Component (N_Loc,
+Prefix => New_Copy_Tree (Lhs),
+Selector_Name => New_Occurrence_Of
+  (Discriminal_Link (Entity (N)), N_Loc));
+   if Present (Val) then
+  Rewrite (N, New_Copy_Tree (Val));
+   end if;
+end if;
+
+return OK;
+ end Replace_Discr_Ref;
+
+ procedure Replace_Discriminant_References is
+   new Traverse_Proc (Replace_Discr_Ref);
+
   begin
  Lhs :=
Make_Selected_Component (N_Loc,
@@ -1789,6 +1825,22 @@
  Selector_Name => New_Occurrence_Of (Id, N_Loc));
  Set_Assignment_OK (Lhs);
 
+ if Nkind (Exp) = N_Aggregate
+   and then Has_Discriminants (Typ)
+   and then not Is_Constrained (Base_Type (Typ))
+ then
+--  The aggregate may provide new values for the discriminants
+--  of the component, and other components may depend on those
+--  discriminants. Previous analysis of those expressions have
+--  replaced the discriminants by the formals of the initialization
+--  procedure for the type, but these are irrelevant in the
+--  enclosing initialization procedure: those discriminant
+--  references must be replaced by the values provided in the
+--  aggregate.
+
+Replace_Discriminant_References (Exp);
+ end if;
+
  --  Case of an access attribute applied to the current instance.
  --  Replace the reference to the type by a reference to the actual
  --  object. (Note that this handles the case of the top level of
Index: ../testsuite/gnat.dg/default_variants.adb
===
--- ../testsuite/gnat.dg/default_variants.adb   (revision 0)
+++ ../testsuite/gnat.dg/default_variants.adb   (revision 0)
@@ -0,0 +1,28 @@
+--  { dg-do compile }
+
+procedure Default_Variants is
+
+   type Variant_Kind is (A, B);
+
+   function Get_Default_Value (Kind : in Variant_Kind) return Natural is (10);
+
+   type Variant_Type (Kind : Variant_Kind := A) is
+  record
+ Common : Natural := Get_Default_Value (Kind);
+ case Kind is
+when A =>
+   A_Value : Integer := Integer'First;
+when B =>
+   B_Value : Natural := Natural'First;
+ end case;
+  end record;
+
+   type Containing_Type is tagged
+  record
+ Variant_Data : Variant_Type :=
+   (Kind => B, Common => <>, B_Value => 1);
+  end record;
+
+begin
+null;
+end Default_Variants;

Re: [Ada] Validity check failure with packed array and pragma

[Pierre-Marie de Rodat]

On 09/18/2017 10:09 PM, Eric Botcazou wrote:

I'm not sure anyone really cares so it's up to you I'd say.


Ok, thanks. Done! Committed as r252971.

--
Pierre-Marie de Rodat

Re: [PATCH][2/2] early LTO debug, main part

[Pierre-Marie de Rodat]

On 09/20/2017 08:08 PM, Jeff Law wrote:

As for general DWARF5 testing, I think best coverage is GDB (say guality
testing with -gdwarf-5), I think GDB 8.0 should have the needed support.
I'll try to install it (am only at 7.12.1 right now) and try to do some
testing.

> What about Pierre-Marie's work to be able to use python to parse and
check dwarf output?


I’m not sure from reading the thread what is to be tested, here. Is it 
just the presence of the .debug_line_str section? (in which case for 
once just scanning the .s sounds enough) Or is it rather about checking 
that objdump (or alike) can properly parse the line table?


--
Pierre-Marie de Rodat

Re: [PATCH] Add comments to struct cgraph_thunk_info

[Pierre-Marie de Rodat]

On 09/16/2017 09:35 AM, Bernhard Reutner-Fischer wrote:

+ * for result-adjusting thinks, the FIXED_OFFSET adjustment is done after

s/think/thunk/
TIA


Good catch, thank you! I just pushed the following obvious change, as 
r252904:


Fix a typo in a comment (cgraph.c:cgraph_thunk_info)

gcc/
* cgraph.h (cgraph_thunk_info): Fix a typo in a comment.

diff --git a/gcc/cgraph.h b/gcc/cgraph.h
index c668b37ef82..7daca1e40cc 100644
--- a/gcc/cgraph.h
+++ b/gcc/cgraph.h
@@ -662,7 +662,7 @@ struct GTY(()) cgraph_thunk_info {
  * for this-adjusting thunks, after the FIXED_OFFSET based 
adjustment is

done, add to the result the offset found in the vtable at:
 vptr + VIRTUAL_VALUE
- * for result-adjusting thinks, the FIXED_OFFSET adjustment is done 
after
+ * for result-adjusting thunks, the FIXED_OFFSET adjustment is done 
after

the virtual one.  */
   bool virtual_offset_p;


--
Pierre-Marie de Rodat

[Ada] Detect protected types as program units

[Pierre-Marie de Rodat]

Routine Unit_Declaration_Node now recognizes protected types as program
units and returns their declaration nodes; previously it returned
declaration nodes of the enclosing program units. This was an oversight.


-- Source --


--  illegal.ads

package Illegal
  with SPARK_Mode
is
   protected type PT
 with SPARK_Mode => Off
   is
   end PT;

end Illegal;

--  illegal.adb

package body Illegal
  with SPARK_Mode
is
   protected body PT
 with SPARK_Mode--  Error
   is
   end PT;

end Illegal;


-- Compilation and output --


$ gcc -c illegal.adb 
illegal.adb:5:11: incorrect use of SPARK_Mode
illegal.adb:5:11: value Off was set for SPARK_Mode on "PT" at illegal.ads:5

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

2017-10-09  Piotr Trojanek  

* sem_aux.adb (Unit_Declaration_Node): Detect protected declarations,
just like other program units listed in Ada RM 10.1(1).

Index: sem_aux.adb
===
--- sem_aux.adb (revision 253546)
+++ sem_aux.adb (working copy)
@@ -1693,6 +1693,7 @@
 and then Nkind (N) /= N_Package_Renaming_Declaration
 and then Nkind (N) /= N_Procedure_Instantiation
 and then Nkind (N) /= N_Protected_Body
+and then Nkind (N) /= N_Protected_Type_Declaration
 and then Nkind (N) /= N_Subprogram_Declaration
 and then Nkind (N) /= N_Subprogram_Body
 and then Nkind (N) /= N_Subprogram_Body_Stub

[Ada] Warnings for ineffective use clauses unclear

[Pierre-Marie de Rodat]

This patch modifies the warnings denoting ineffective use-clauses to be more
explicit and user-friendly.


-- Source --


--  unused_a.adb

with Ada.Text_IO;
with Interfaces;

procedure Unused_A is
   use type Interfaces.Unsigned_8;
begin
   Ada.Text_IO.Put_Line ("Hello, World!");
end;

--  unused_b.adb

with Ada.Text_IO;
with Interfaces;

procedure Unused_B is
   use type Interfaces.Unsigned_32;
   Val : Interfaces.Unsigned_32 := 5;
begin
   Ada.Text_IO.Put_Line ("Hello, World!" & Interfaces.Unsigned_32'Image (Val));
end;

--  unused_c.adb

with Ada.Text_IO;
with Interfaces;

procedure Unused_C is
   Val : Interfaces.Unsigned_32 := 5;
begin
   Ada.Text_IO.Put_Line ("Hello, World!" & Interfaces.Unsigned_32'Image (Val));

   declare
  use Interfaces; -- no warning that this is useless here
   begin
  Ada.Text_IO.Put_Line ("Goodbye!");
   end;

end;


-- Compilation and output --


& gnatmake -gnatwu -q unused_a.adb
& gnatmake -gnatwu -q unused_b.adb
& gnatmake -gnatwu -q unused_c.adb

unused_a.adb:5:04: warning: use clause for type "Interfaces.Unsigned_8"
 has no effect
unused_b.adb:5:04: warning: use clause for type "Interfaces.Unsigned_32"
 has no effect
unused_c.adb:10:07: warning: use clause for package "Interfaces" has no effect

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

2017-10-09  Justin Squirek  

* sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages.

Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 253546)
+++ sem_ch8.adb (working copy)
@@ -9069,7 +9069,7 @@
  (Current_Use_Clause (Associated_Node (N
   then
  Error_Msg_Node_1 := Entity (N);
- Error_Msg_NE ("ineffective use clause for package &?",
+ Error_Msg_NE ("use clause for package &? has no effect",
Curr, Entity (N));
   end if;
 
@@ -9077,7 +9077,7 @@
 
else
   Error_Msg_Node_1 := Etype (N);
-  Error_Msg_NE ("ineffective use clause for }?",
+  Error_Msg_NE ("use clause for }? has no effect",
  Curr, Etype (N));
end if;
 end if;

[Ada] Crash on validity check on actual with type conversion

[Pierre-Marie de Rodat]

This patch fixes a compiler crash on a function call when validity checks
on actuals are enabled (-gnatVi) and the target type is a scalar type.

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

gcc/ada/

2017-10-09  Ed Schonberg  

* exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of
the attribute is an object, but it may appear within a conversion. The
object itself must be retrieved when generating the range test that
implements the validity check on a scalar type.

gcc/testsuite/

2017-10-09  Ed Schonberg  

* gnat.dg/validity_check2.adb, gnat.dg/validity_check2_pkg.ads:
New testcase.
Index: exp_attr.adb
===
--- exp_attr.adb(revision 253546)
+++ exp_attr.adb(working copy)
@@ -6512,7 +6512,9 @@
  begin
 --  The prefix of attribute 'Valid should always denote an object
 --  reference. The reference is either coming directly from source
---  or is produced by validity check expansion.
+--  or is produced by validity check expansion. The object may be
+--  wrapped in a conversion in which case the call to Unqual_Conv
+--  will yield it.
 
 --  If the prefix denotes a variable which captures the value of
 --  an object for validation purposes, use the variable in the
@@ -6523,7 +6525,7 @@
 --if not Temp in ... then
 
 if Is_Validation_Variable_Reference (Pref) then
-   Temp := New_Occurrence_Of (Entity (Pref), Loc);
+   Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
 
 --  Otherwise the prefix is either a source object or a constant
 --  produced by validity check expansion. Generate:
Index: ../testsuite/gnat.dg/validity_check2.adb
===
--- ../testsuite/gnat.dg/validity_check2.adb(revision 0)
+++ ../testsuite/gnat.dg/validity_check2.adb(revision 0)
@@ -0,0 +1,11 @@
+--  { dg-do compile }
+--  { dg-options "-gnatVi -gnatws" }
+
+with Validity_Check2_Pkg; use Validity_Check2_Pkg;
+
+procedure Validity_Check2 (R : access Rec) is
+begin
+  if Op_Code_To_Msg (R.Code) in Valid_Msg then
+raise Program_Error;
+  end if;
+end;
Index: ../testsuite/gnat.dg/validity_check2_pkg.ads
===
--- ../testsuite/gnat.dg/validity_check2_pkg.ads(revision 0)
+++ ../testsuite/gnat.dg/validity_check2_pkg.ads(revision 0)
@@ -0,0 +1,16 @@
+with Ada.unchecked_conversion;
+
+package Validity_Check2_Pkg is
+
+  type Op_Code is (One, Two, Three, Four);
+
+  subtype Valid_Msg is Integer range 0 .. 15;
+
+  function Op_Code_To_Msg is
+new Ada.Unchecked_Conversion (Source => Op_code, Target => Valid_Msg);
+
+  type Rec is record
+Code : Op_Code;
+  end record;
+
+end Validity_Check2_Pkg;

[Ada] Crash on actual that is an instance of a generic child unit

[Pierre-Marie de Rodat]

This patch fixes a compiler abort on an instantiation where the actual for
a formal package is an instantiation of a generic child unit. An instantiation
freezes its actuals, and in the case of formal packages whose instance
includes a body the back-end needs an explicit freeze node for the actual.
If the generic for that actual appears within an enclosing instantiation
that instantiation must be frozen as well. Additionally, if the actual is
an instantiation of a child unit it depends on an instance of its parent
unit, and that instantiation must be frozen as well. Previously only the
first kind of dependence on a previous instantiation was handled properly.

The following must compile quietly:

   gcc -c p.ads

---
with Q;
with Q.Sub1;
with Q.Sub2;
package P is

   type Rec is record
  null;
   end record;

   package My_Q is new Q (Rec);

   package My_Sub1 is new My_Q.Sub1;

   package My_Sub2 is new My_Q.Sub2 (My_Sub1);

end P;
---
generic
   type T is private;
package Q is

   pragma Elaborate_Body;

   package Inner is

  generic
  package G is
  end G;

   end Inner;

end Q;
---
generic
package Q.Sub1 is

  pragma Elaborate_Body;

end Q.Sub1;
---
package body Q.Sub1 is

  package My_G is new Q.Inner.G;

end Q.Sub1;
---
with Q.Sub1;

generic

   with package F is new Q.Sub1 (<>);

package Q.Sub2 is
end Q.Sub2;
---
with R;
package body Q is

   package My_R is new R (T);

   package body Inner is

  package body G is

 package My_H is new My_R.H;

  end G;

   end Inner;

end Q;
---
generic
   type Message is private;
package R is

   pragma Elaborate_Body;

   generic
   package H is
   end H;

end R;
---
package body R is

   type Message_P is access Message;

   package body H is
  Obj : constant Message_P := null;
   end H;

end R;
---

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

2017-10-09  Ed Schonberg  

* sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an
actual for a formal package is an instantiation of a child unit, create
a freeze node for the instance of the parent if it appears in the same
scope and is not frozen yet.

Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 253546)
+++ sem_ch12.adb(working copy)
@@ -1903,7 +1903,8 @@
  --  body.
 
  Explicit_Freeze_Check : declare
-Actual : constant Entity_Id := Entity (Match);
+Actual  : constant Entity_Id := Entity (Match);
+Gen_Par : Entity_Id;
 
 Needs_Freezing : Boolean;
 S  : Entity_Id;
@@ -1912,7 +1913,11 @@
 --  The actual may be an instantiation of a unit
 --  declared in a previous instantiation. If that
 --  one is also in the current compilation, it must
---  itself be frozen before the actual.
+--  itself be frozen before the actual. The actual
+--  may be an instantiation of a generic child unit,
+--  in which case the same applies to the instance
+--  of the parent which must be frozen before the
+--  actual.
 --  Should this itself be recursive ???
 
 --
@@ -1920,30 +1925,71 @@
 --
 
 procedure Check_Generic_Parent is
-   Par : Entity_Id;
+   Inst : constant Node_Id :=
+  Next (Unit_Declaration_Node (Actual));
+   Par  : Entity_Id;
 
 begin
-   if Nkind (Parent (Actual)) =
-N_Package_Specification
+   Par := Empty;
+
+   if Nkind (Parent (Actual)) = N_Package_Specification
then
   Par := Scope (Generic_Parent (Parent (Actual)));
+  if Is_Generic_Instance (Par) then
+ null;
 
-  if Is_Generic_Instance (Par)
-and then Scope (Par) = Current_Scope
-and then
-  (No (Freeze_Node (Par))
-or else
-  not Is_List_Member (Freeze_Node (Par)))
+  --  If the actual is a child generic unit, check
+  --  whether the instantiation of the parent is
+  --  also local and must also be frozen now.
+   

[Add] Spurious ambiguity in prefixed call to classwide operation

[Pierre-Marie de Rodat]

This patch suppresses a spurious ambiguity error on a prefixed call to an
inherited class-wide operation, when the operation also has other visible
homonyms in the context.

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

gcc/ada/

2017-10-09  Ed Schonberg  

* sem_ch4.adb (Try_Class_Wide_Operation, Traverse_Homonyms):
Suppress spurious ambiguity error when two traversals of the homonym
chain (first directly, and then through an examination of relevant
interfaces) retrieve the same operation, when other irrelevant homonyms
of the operatioh are also present.

gcc/testsuite/

2017-10-09  Ed Schonberg  

* gnat.dg/class_wide3.adb, gnat.dg/class_wide3_pkg.ads: New testcase.
Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 253546)
+++ sem_ch4.adb (working copy)
@@ -8860,7 +8860,7 @@
 while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function)
  and then (not Is_Hidden (Hom) or else In_Instance)
- and then Scope (Hom) = Scope (Anc_Type)
+ and then Scope (Hom) = Scope (Base_Type (Anc_Type))
  and then Present (First_Formal (Hom))
  and then
(Base_Type (Etype (First_Formal (Hom))) = Cls_Type
@@ -8921,8 +8921,13 @@
 Success=> Success,
 Skip_First => True);
 
+ --  The same operation may be encountered on two homonym
+ --  traversals, before and after looking at interfaces.
+ --  Check for this case before reporting a real ambiguity.
+
  if Present (Valid_Candidate (Success, Call_Node, Hom))
and then Nkind (Call_Node) /= N_Function_Call
+   and then Hom /= Matching_Op
  then
 Error_Msg_NE ("ambiguous call to&", N, Hom);
 Report_Ambiguity (Matching_Op);
Index: ../testsuite/gnat.dg/class_wide3.adb
===
--- ../testsuite/gnat.dg/class_wide3.adb(revision 0)
+++ ../testsuite/gnat.dg/class_wide3.adb(revision 0)
@@ -0,0 +1,8 @@
+with Ada.Text_IO; use Ada.Text_IO;
+with Class_Wide3_Pkg; use Class_Wide3_Pkg;
+
+procedure Class_Wide3 is
+   DC : Disc_Child := (N => 1, I => 3, J => 5);
+begin
+   DC.Put_Line;
+end Class_Wide3;
Index: ../testsuite/gnat.dg/class_wide3_pkg.ads
===
--- ../testsuite/gnat.dg/class_wide3_pkg.ads(revision 0)
+++ ../testsuite/gnat.dg/class_wide3_pkg.ads(revision 0)
@@ -0,0 +1,16 @@
+package Class_Wide3_Pkg is
+
+   type Iface is interface;
+   type Iface_Ptr is access all Iface'Class;
+
+   procedure Put_Line (I : Iface'Class);
+
+   type Root is tagged record
+  I : Integer;
+   end record;
+
+   type Disc_Child (N : Integer) is new Root and Iface with record
+  J : Integer;
+   end record;
+
+end Class_Wide3_Pkg;

Re: r253554 - in /trunk/gcc: ada/ChangeLog ada/exp_...

[Pierre-Marie de Rodat]

Hello Andreas,

On 10/10/2017 04:44 AM, Andreas Schwab wrote:

On Okt 09 2017, pmdero...@gcc.gnu.org wrote:


2017-10-09  Ed Schonberg  <schonb...@adacore.com>

* gnat.dg/class_wide4.adb, gnat.dg/class_wide4_pkg.ads,
gnat.dg/class_wide4_pkg2.ads: New testcase.


FAIL: gnat.dg/class_wide4.adb (test for excess errors)
Excess errors:
class_wide4.adb:8:32: "Object" not declared in "Class_Wide4_Pkg"
class_wide4.adb:14:04: invalid prefix in selected component "O"
class_wide4.adb:15:04: invalid prefix in selected component "O"
class_wide4.adb:15:05: prefixed call is only allowed for objects of a tagged 
type
class_wide4.adb:18:04: actual for "This" must be a variable
class_wide4.adb:19:04: actual for "This" must be a variable


Yes, sorry about this. I had the fix locally yesterday when I realized 
this, and I thought I committed it but I guess I got confused with my 
SVN setup. Anyway the fix is now in. Thank you for having reported this!


--
Pierre-Marie de Rodat

[Ada] Suppress checks within finalizers

[Pierre-Marie de Rodat]

This patch suppresses checks within finalizer routines, because they can't
fail. No change in behavior; no test available. This is just an internal
cleanup.

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

2017-10-09  Bob Duff  

* exp_ch7.adb (Create_Finalizer): Suppress checks within the finalizer.

Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 253546)
+++ exp_ch7.adb (working copy)
@@ -1955,7 +1955,7 @@
Insert_After (Finalizer_Insert_Nod, Fin_Body);
 end if;
 
-Analyze (Fin_Body);
+Analyze (Fin_Body, Suppress => All_Checks);
  end if;
   end Create_Finalizer;
 

[Ada] Premature evaluation of message string in Assert pragma

[Pierre-Marie de Rodat]

RM 11.4.2 stipulates that the optional string argument in an Assert pragma is
evaluated only if the assertion fails and the string is incorporated into the
raise statement. Previous to this patch the string expression was evaluated
unconditionally, leading to unwanted side effects if its evaluation only
made sense in case of failure of the assertion.

Executing:

   gnatmake -gnata -gnatws -q main
   main

must yield:

   Assert succeeds

   raised SYSTEM.ASSERTIONS.ASSERT_FAILURE : P should be null, got A_STRING

---
with Text_IO; use Text_IO;
procedure Main is
  P : access String;
  X : Integer;
  function Zero return Integer is begin return 0; end;

begin
  X := Zero;
  pragma Assert (P = null, "P should be null, got " & P.all);
  Put_Line ("Assert succeeds");

  if X = 0 then
  P := new String'("A_STRING");
   end if;

  pragma Assert (P = null, "P should be null, got " & P.all);
end Main;

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

2017-10-14  Ed Schonberg  

* sem_prag.adb (Analyze_Pragma, case Check): Defer evaluation of the
optional string in an Assert pragma until the expansion of the pragma
has rewritten it as a conditional statement, so that the string
argument is only evaluaed if the assertion fails. This is mandated by
RM 11.4.2.

Index: sem_prag.adb
===
--- sem_prag.adb(revision 253754)
+++ sem_prag.adb(working copy)
@@ -13249,16 +13249,18 @@
--  If checks are not on we don't want any expansion (since
--  such expansion would not get properly deleted) but
--  we do want to analyze (to get proper references).
-   --  The Preanalyze_And_Resolve routine does just what we want
+   --  The Preanalyze_And_Resolve routine does just what we want.
+   --  Ditto if pragma is active, because it will be rewritten
+   --  as an if-statement whose analysis will complete analysis
+   --  and expansion of the string message. This makes a
+   --  difference in the unusual case where the expression for
+   --  the string may have a side effect, such as raising an
+   --  exception. This is mandated by RM 11.4.2, which specifies
+   --  that the string expression is only evaluated if the
+   --  check fails and Assertion_Error is to be raised.
 
-   if Is_Ignored (N) then
-  Preanalyze_And_Resolve (Str, Standard_String);
+   Preanalyze_And_Resolve (Str, Standard_String);
 
-  --  Otherwise we need a proper analysis and expansion
-
-   else
-  Analyze_And_Resolve (Str, Standard_String);
-   end if;
 end if;
 
 --  Now you might think we could just do the same with the Boolean

[Ada] Repair ABI breakage on 32-bit x86/Linux

[Pierre-Marie de Rodat]

This repairs the ABI breakage for record types with Long_Float components
introduced on 32-bit x86/Linux by the previous change.  The Long_Float type
is awkward on this platform because it has got a dual alignment setting:
it's 8 for standalone object and array component and 4 for record component.
Since Ada defines a single 'Alignment value, it is set to 4 and there is a
special circuitry in Set_Elem_Alignment to implement it.

The previous change short-circuited Set_Elem_Alignment in Build_Float_Type,
which resulted in a Long_Float'Alignment value of 8.

The following package:

package P is

  type Rec is record
I : Integer;
F : Long_Float;
  end record;

end P;

must yield the following output when compiled with -gnatR2 on 32-bit Linux:

Representation information for unit P (spec)

for Rec'Size use 96;
for Rec'Alignment use 4;
for Rec use record
   I at 0 range  0 .. 31;
   F at 4 range  0 .. 63;
end record;

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

2017-10-14  Eric Botcazou  

* layout.ads (Set_Elem_Alignment): Add Align parameter defaulted to 0.
* layout.adb (Set_Elem_Alignment): Likewise.  Use M name as maximum
alignment for consistency.  If Align is non-zero, use the minimum of
Align and M for the alignment.
* cstand.adb (Build_Float_Type): Use Set_Elem_Alignment instead of
setting the alignment directly.

Index: cstand.adb
===
--- cstand.adb  (revision 253756)
+++ cstand.adb  (working copy)
@@ -212,7 +212,7 @@
   Init_Digits_Value  (E, Digs);
   Set_Float_Rep  (E, Rep);
   Init_Size  (E, Siz);
-  Set_Alignment  (E, UI_From_Int (Align));
+  Set_Elem_Alignment (E, Align);
   Set_Float_Bounds   (E);
   Set_Is_Frozen  (E);
   Set_Is_Public  (E);
Index: layout.adb
===
--- layout.adb  (revision 253753)
+++ layout.adb  (working copy)
@@ -843,7 +843,7 @@
-- Set_Elem_Alignment --

 
-   procedure Set_Elem_Alignment (E : Entity_Id) is
+   procedure Set_Elem_Alignment (E : Entity_Id; Align : Nat := 0) is
begin
   --  Do not set alignment for packed array types, this is handled in the
   --  backend.
@@ -869,16 +869,13 @@
  return;
   end if;
 
-  --  Here we calculate the alignment as the largest power of two multiple
-  --  of System.Storage_Unit that does not exceed either the object size of
-  --  the type, or the maximum allowed alignment.
+  --  We attempt to set the alignment in all the other cases
 
   declare
  S : Int;
  A : Nat;
+ M : Nat;
 
- Max_Alignment : Nat;
-
   begin
  --  The given Esize may be larger that int'last because of a previous
  --  error, and the call to UI_To_Int will fail, so use default.
@@ -908,7 +905,7 @@
and then S = 8
and then Is_Floating_Point_Type (E)
  then
-Max_Alignment := Ttypes.Target_Double_Float_Alignment;
+M := Ttypes.Target_Double_Float_Alignment;
 
  --  If the default alignment of "double" or larger scalar types is
  --  specifically capped, enforce the cap.
@@ -917,19 +914,28 @@
and then S >= 8
and then Is_Scalar_Type (E)
  then
-Max_Alignment := Ttypes.Target_Double_Scalar_Alignment;
+M := Ttypes.Target_Double_Scalar_Alignment;
 
  --  Otherwise enforce the overall alignment cap
 
  else
-Max_Alignment := Ttypes.Maximum_Alignment;
+M := Ttypes.Maximum_Alignment;
  end if;
 
- A := 1;
- while 2 * A <= Max_Alignment and then 2 * A <= S loop
-A := 2 * A;
- end loop;
+ --  We calculate the alignment as the largest power-of-two multiple
+ --  of System.Storage_Unit that does not exceed the object size of
+ --  the type and the maximum allowed alignment, if none was specified.
+ --  Otherwise we only cap it to the maximum allowed alignment.
 
+ if Align = 0 then
+A := 1;
+while 2 * A <= S and then 2 * A <= M loop
+   A := 2 * A;
+end loop;
+ else
+A := Nat'Min (Align, M);
+ end if;
+
  --  If alignment is currently not set, then we can safely set it to
  --  this new calculated value.
 
Index: layout.ads
===
--- layout.ads  (revision 253753)
+++ layout.ads  (working copy)
@@ -74,10 +74,11 @@
--  types, the RM_Size is simply set to zero. This routine also sets
--  the Is_Constrained flag in Def_Id.
 
-   procedure Set_Elem_Alignment (E : Entity_Id);
+   procedure 

[Ada] Activation/suppression of SPARK elaboration rules

[Pierre-Marie de Rodat]

This patch utilizes compilation switch -gnatd.v to enforce the SPARK rules for
elaboration in SPARK code. The affected scenarios are calls and instantiations.
If the switch is active, the ABE mechanism will verify that the scenarios have
fulfilled their Elaborate[_All] requirements. Otherwise the static model of the
ABE mechanism will install implicit Elaborate[_All] pragmas to meet these
requirements.


-- Source --


--  server.ads

package Server with SPARK_Mode is
   generic
   procedure Gen_Proc;

   generic
   package Gen_Pack is
  procedure Proc;
   end Gen_Pack;

   function Func return Boolean;
end Server;

--  server.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Server with SPARK_Mode is
   procedure Gen_Proc is
   begin
  Put_Line ("Gen_Proc");
   end Gen_Proc;

   package body Gen_Pack is
  procedure Proc is
  begin
 Put_Line ("Proc");
  end Proc;
   end Gen_Pack;

   function Func return Boolean is
   begin
  Put_Line ("Func");
  return True;
   end Func;
end Server;

--  client.ads

with Server;

package Client with SPARK_Mode is
   procedure Inst_Proc is new Server.Gen_Proc;
   package   Inst_Pack is new Server.Gen_Pack;

   Val : constant Boolean := Server.Func;
end Client;


-- Compilation and output --


$ echo "Ignore SPARK rules"
$ gcc -c client.ads
$ echo "Apply SPARK rules"
$ gcc -c client.ads -gnatd.v
Ignore SPARK rules
Apply SPARK rules
client.ads:4:04: instantiation of "Gen_Proc" during elaboration in SPARK
client.ads:4:04: unit "Client" requires pragma "Elaborate_All" for "Server"
client.ads:4:04:   spec of unit "Client" elaborated
client.ads:4:04:   procedure "Gen_Proc" instantiated as "Inst_Proc" at line 4
client.ads:5:04: instantiation of "Gen_Pack" during elaboration in SPARK
client.ads:5:04: unit "Client" requires pragma "Elaborate" for "Server"
client.ads:5:04:   spec of unit "Client" elaborated
client.ads:5:04:   package "Gen_Pack" instantiated as "Inst_Pack" at line 5
client.ads:7:36: call to "Func" during elaboration in SPARK
client.ads:7:36: unit "Client" requires pragma "Elaborate_All" for "Server"
client.ads:7:36:   spec of unit "Client" elaborated
client.ads:7:36:   function "Func" called at line 7

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

2017-10-14  Hristian Kirtchev  

* debug.adb: Switch -gnatd.v and associated flag are now used to
enforce the SPARK rules for elaboration in SPARK code.
* sem_elab.adb: Describe switch -gnatd.v.
(Process_Call): Verify the SPARK rules only when -gnatd.v is in effect.
(Process_Instantiation): Verify the SPARK rules only when -gnatd.v is
in effect.
(Process_Variable_Assignment): Clarify why variable assignments are
processed reglardless of whether -gnatd.v is in effect.
* doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update the
sections on elaboration code and compilation switches.
* gnat_ugn.texi: Regenerate.

Index: doc/gnat_ugn/elaboration_order_handling_in_gnat.rst
===
--- doc/gnat_ugn/elaboration_order_handling_in_gnat.rst (revision 253753)
+++ doc/gnat_ugn/elaboration_order_handling_in_gnat.rst (working copy)
@@ -133,9 +133,44 @@
 =
 
 The sequence by which the elaboration code of all units within a partition is
-executed is referred to as **elaboration order**. The elaboration order depends
-on the following factors:
+executed is referred to as **elaboration order**.
 
+Within a single unit, elaboration code is executed in sequential order.
+
+::
+
+   package body Client is
+  Result : ... := Server.Func;
+
+  procedure Proc is
+ package Inst is new Server.Gen;
+  begin
+ Inst.Eval (Result);
+  end Proc;
+   begin
+  Proc;
+   end Client;
+
+In the example above, the elaboration order within package body ``Client`` is
+as follows:
+
+1. The object declaration of ``Result`` is elaborated.
+
+   * Function ``Server.Func`` is invoked.
+
+2. The subprogram body of ``Proc`` is elaborated.
+
+3. Procedure ``Proc`` is invoked.
+
+   * Generic unit ``Server.Gen`` is instantiated as ``Inst``.
+
+   * Instance ``Inst`` is elaborated.
+
+   * Procedure ``Inst.Eval`` is invoked.
+
+The elaboration order of all units within a partition depends on the following
+factors:
+
 * |withed| units
 
 * purity of units
@@ -571,7 +606,7 @@
   a partition is elaboration code. GNAT performs very few diagnostics and
   generates run-time checks to verify the elaboration order of a program. This
   behavior is identical to that specified by the Ada Reference Manual. The
-  dynamic model is enabled with compilation switch :switch:`-gnatE`.
+  dynamic model is enabled with compiler switch :switch:`-gnatE`.
 
 .. index:: Static elaboration model
 
@@ -860,7 +895,7 @@
 The SPARK model is identical 

[Ada] Calls in preelaborated units and pragma Remote_Call_Interface

[Pierre-Marie de Rodat]

This patch modifies the check which ensures that no call is executed in a
preelaborated unit. The check now properly ignores a case where a generic
unit is subject to pragma Remote_Call_Interface, and the call appears in
the body.

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

gcc/ada/

2017-10-14  Hristian Kirtchev  

* sem_elab.adb (In_Preelaborated_Context): A generic package subject to
Remote_Call_Interface is not a suitable preelaboratd context when the
call appears in the package body.

gcc/testsuite/

2017-10-14  Hristian Kirtchev  

* gnat.dg/remote_call_iface.ads, gnat.dg/remote_call_iface.adb: New
testcase.
Index: sem_elab.adb
===
--- sem_elab.adb(revision 253757)
+++ sem_elab.adb(working copy)
@@ -1808,7 +1808,7 @@
  --  be on another machine.
 
  if Ekind (Body_Id) = E_Package_Body
-   and then Ekind (Spec_Id) = E_Package
+   and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
and then (Is_Remote_Call_Interface (Spec_Id)
   or else Is_Remote_Types (Spec_Id))
  then
Index: ../testsuite/gnat.dg/remote_call_iface.ads
===
--- ../testsuite/gnat.dg/remote_call_iface.ads  (revision 0)
+++ ../testsuite/gnat.dg/remote_call_iface.ads  (revision 0)
@@ -0,0 +1,5 @@
+generic
+package Remote_Call_Iface is
+   pragma Remote_Call_Interface;
+   procedure Proc;
+end Remote_Call_Iface;
Index: ../testsuite/gnat.dg/remote_call_iface.adb
===
--- ../testsuite/gnat.dg/remote_call_iface.adb  (revision 0)
+++ ../testsuite/gnat.dg/remote_call_iface.adb  (revision 0)
@@ -0,0 +1,7 @@
+--  { dg-do compile }
+
+package body Remote_Call_Iface is
+   procedure Proc is begin null; end;
+begin
+   Proc;
+end Remote_Call_Iface;

[Ada] Missing warning about replacement of warnings off for unreferenced

[Pierre-Marie de Rodat]

This patch corrects an issue introduced by Q220-025 where the use of pragma
warnings off applied to an unreferenced variable is not warned about the
possibility of replacing with the more specific pragma unreferenced when using
the -gnatw.w.


-- Source --


--  p.adb

procedure P is
   X : Integer;
   pragma Warnings (Off, X);
begin
   X := 12 + 53;
end;


-- Compilation and output --


& gnatmake p.adb -gnatw.w -q
p.adb:3:11: warning: could use Unreferenced instead of Warnings Off for "X"

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

2017-10-14  Justin Squirek  

* sem_elab.adb (Is_Suitable_Variable_Assignment): Replace call to
Has_Warnings_Off with Warnings_Off.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 253753)
+++ sem_elab.adb(working copy)
@@ -5186,7 +5186,7 @@
 --  The variable must be a source entity and susceptible to warnings
 
 Comes_From_Source (Var_Id)
-  and then not Has_Warnings_Off (Var_Id)
+  and then not Warnings_Off (Var_Id)
 
   --  The variable must be declared in the spec of compilation unit U
 

[Ada] Proper resolution of Initializes and Initial_Condition

[Pierre-Marie de Rodat]

This patch modifies the processing of SPARK annotations Initializes and
Initial_Condition to perform the resolution of the related expressions
at the end of the enclosing package visible declarations.


-- Source --


--  init_cond.ads

package Init_Cond
  with SPARK_Mode,
   Initial_Condition =>
 Vis_Var --  OK
   and Vis_Func  --  OK
   and Vis_Nested.Var--  OK
   and Vis_Nested.Func   --  OK
   and Priv_Var  --  Error
   and Priv_Func --  Error
   and Priv_Nested.Var   --  Error
   and Priv_Nested.Func  --  Error

is
   Vis_Var : Boolean := False;
   function Vis_Func return Boolean;

   package Vis_Nested is
  Var : Boolean := True;
  function Func return Boolean;
   end Vis_Nested;

private
   Priv_Var : Boolean := False;
   function Priv_Func return Boolean;

   package Priv_Nested is
  Var : Boolean := True;
  function Func return Boolean;
   end Priv_Nested;
end Init_Cond;


-- Compilation and output --


$ gcc -c init_cond.ads
init_cond.ads:8:16: "Priv_Var" is undefined
init_cond.ads:9:16: "Priv_Func" is undefined
init_cond.ads:10:16: "Priv_Nested" is undefined (more references follow)

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

2017-10-14  Hristian Kirtchev  

* sem_ch3.adb (Analyze_Declarations): Analyze the contract of an
enclosing package at the end of the visible declarations.
* sem_prag.adb (Analyze_Initialization_Item): Suppress the analysis of
an initialization item which is undefined due to some illegality.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 253753)
+++ sem_ch3.adb (working copy)
@@ -2820,25 +2820,11 @@
 
  --  Analyze the contracts of packages and their bodies
 
- if Nkind (Context) = N_Package_Specification then
+ if Nkind (Context) = N_Package_Specification
+   and then L = Visible_Declarations (Context)
+ then
+Analyze_Package_Contract (Defining_Entity (Context));
 
---  When a package has private declarations, its contract must be
---  analyzed at the end of the said declarations. This way both the
---  analysis and freeze actions are properly synchronized in case
---  of private type use within the contract.
-
-if L = Private_Declarations (Context) then
-   Analyze_Package_Contract (Defining_Entity (Context));
-
---  Otherwise the contract is analyzed at the end of the visible
---  declarations.
-
-elsif L = Visible_Declarations (Context)
-  and then No (Private_Declarations (Context))
-then
-   Analyze_Package_Contract (Defining_Entity (Context));
-end if;
-
  elsif Nkind (Context) = N_Package_Body then
 Analyze_Package_Body_Contract (Defining_Entity (Context));
  end if;
Index: sem_prag.adb
===
--- sem_prag.adb(revision 253753)
+++ sem_prag.adb(working copy)
@@ -2818,10 +2818,16 @@
  E_Constant,
  E_Variable)
then
+  --  When the initialization item is undefined, it appears as
+  --  Any_Id. Do not continue with the analysis of the item.
+
+  if Item_Id = Any_Id then
+ null;
+
   --  The state or variable must be declared in the visible
   --  declarations of the package (SPARK RM 7.1.5(7)).
 
-  if not Contains (States_And_Objs, Item_Id) then
+  elsif not Contains (States_And_Objs, Item_Id) then
  Error_Msg_Name_1 := Chars (Pack_Id);
  SPARK_Msg_NE
("initialization item & must appear in the visible "

[Ada] Remove obsolete comment for Generic_Parent

[Pierre-Marie de Rodat]

Routine [Set_]Generic_Parent can only be called on package, function
and procedure specification nodes, as asserted in their bodies. It would
crash when called for renaming or object declarations; the comment was
most likely referring to some earlier implemenation idea.

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

2017-10-14  Piotr Trojanek  

* sinfo.ads (Generic_Parent): Remove wrong (possibly obsolete) comment.

Index: sinfo.ads
===
--- sinfo.ads   (revision 253753)
+++ sinfo.ads   (working copy)
@@ -1472,10 +1472,7 @@
--  Generic_Parent (Node5-Sem)
--Generic_Parent is defined on declaration nodes that are instances. The
--value of Generic_Parent is the generic entity from which the instance
-   --is obtained. Generic_Parent is also defined for the renaming
-   --declarations and object declarations created for the actuals in an
-   --instantiation. The generic parent of such a declaration is the
-   --corresponding generic association in the Instantiation node.
+   --is obtained.
 
--  Generic_Parent_Type (Node4-Sem)
--Generic_Parent_Type is defined on Subtype_Declaration nodes for the

[Ada] Variable assignments and reads in SPARK elaboration code

[Pierre-Marie de Rodat]

This patch reimplements the treatment of variable assignments and reads within
SPARK elaboration code. The changes are as follows:

1) Diagnostics of variable assignments in elaboration code are now based on the
   rules in effect (either Ada or SPARK).

2) Variable assignments in Ada elaboration code are considered problematic
   when a variable declared at the library level of a package spec without
   pragma Elaborate_Body lacks initialization, and the elaboration code of
   the corresponding package body initializes it. The compiler continues to
   emit a warning suggesting pragma Elaborate_Body on the package spec.

3) Variable assignments in SPARK elaboration code are considered problematic
   when a variable declared at the library level of a package spec without
   pragma Elaborate_Body is initialized, and the elaboration code of the
   corresponding package body further modifies the variable. The compiler
   emits an error on the missing Elaborate_Body.

4) A read of an external variable now imposes an Elaborate requirement on the
   unit performing the read, unless the variable is initialied, or the spec of
   the external unit carries pragma Elaborate_Body.


-- Source --


--  c1_pack.ads

with S1_Pack; use S1_Pack;

package C1_Pack with SPARK_Mode is
   Local : constant Integer := Var;--  needs Elaborate

   function Reference_Var return Boolean;
end C1_Pack;

--  c1_pack.adb

package body C1_Pack with SPARK_Mode is
   function Reference_Var return Boolean is
  procedure Read (Formal : Integer) is
  begin
 null;
  end Read;

  procedure Read_Write (Formal : in out Integer) is
  begin
 Formal := Formal + 1;
  end Read_Write;

  procedure Write (Formal : out Integer) is
  begin
 Formal := 123;
  end Write;

  Local : Integer;

   begin
  Read (Var);  --  needs Elaborate
  Read_Write (Var);--  needs Elaborate
  Local := Var;--  needs Elaborate

  Write (Var); --  OK
  Var := 234;  --  OK

  return True;
   end Reference_Var;

   Ref : constant Boolean := Reference_Var;
end C1_Pack;

--  c2_pack.ads

with S2_Pack; use S2_Pack;

package C2_Pack with SPARK_Mode is
   Local : constant Integer := Var;--  OK

   function Reference_Var return Boolean;
end C2_Pack;

--  c2_pack.adb

package body C2_Pack with SPARK_Mode is
   function Reference_Var return Boolean is
  procedure Read (Formal : Integer) is
  begin
 null;
  end Read;

  procedure Read_Write (Formal : in out Integer) is
  begin
 Formal := Formal + 1;
  end Read_Write;

  procedure Write (Formal : out Integer) is
  begin
 Formal := 123;
  end Write;

  Local : Integer;

   begin
  Read (Var);  --  OK
  Read_Write (Var);--  OK
  Local := Var;--  OK

  Write (Var); --  OK
  Var := 234;  --  OK

  return True;
   end Reference_Var;

   Ref : constant Boolean := Reference_Var;
end C2_Pack;

--  c3_pack.ads

with S3_Pack; use S3_Pack;
pragma Elaborate (S3_Pack);

package C3_Pack with SPARK_Mode is
   Local : constant Integer := Var;--  OK

   function Reference_Var return Boolean;
end C3_Pack;

--  c3_pack.adb

package body C3_Pack with SPARK_Mode is
   function Reference_Var return Boolean is
  procedure Read (Formal : Integer) is
  begin
 null;
  end Read;

  procedure Read_Write (Formal : in out Integer) is
  begin
 Formal := Formal + 1;
  end Read_Write;

  procedure Write (Formal : out Integer) is
  begin
 Formal := 123;
  end Write;

  Local : Integer;

   begin
  Read (Var);  --  OK
  Read_Write (Var);--  OK
  Local := Var;--  OK

  Write (Var); --  OK
  Var := 234;  --  OK

  return True;
   end Reference_Var;

   Ref : constant Boolean := Reference_Var;
end C3_Pack;

--  c4_pack.ads

with S4_Pack; use S4_Pack;
pragma Elaborate (S4_Pack);

package C4_Pack with SPARK_Mode is
   Local : constant Integer := Var;--  OK

   function Reference_Var return Boolean;
end C4_Pack;

--  c4_pack.adb

package body C4_Pack with SPARK_Mode is
   function Reference_Var return Boolean is
  procedure Read (Formal : Integer) is
  begin
 null;
  end Read;

  procedure Read_Write 

[Ada] Missing validity check on record type component

[Pierre-Marie de Rodat]

The compiler may silently skip generating a validity check on a
type conversion of a component of a record type. After this patch
the error is reported on the following sources.

pragma Initialize_Scalars;
package Pkg is
   type T is record
  Major : Natural;
  Minor : Natural;
   end record;

   procedure Do_Test (Value : in out T);
end;

pragma Initialize_Scalars;
package body Pkg is
   typeInteger_T is range -2 ** 31 .. 2 ** 31 - 1;
   subtype Natural_T is Integer_T range 0 .. Integer_T'Last;
   Next_Val : Integer_T := 0;

   procedure Do_Update (Int : in out Integer_T) is
   begin
  Next_Val := Next_Val + 1;
  if Next_Val > 1000 then
 Next_Val := Int;
  else
 Int := Next_Val;
  end if;
   end;

   procedure Do_Test (Value : in out T) is
   begin
  Do_Update (Natural_T (Value.Minor));   -- Run-time error
   end;

end;

with Pkg; use Pkg;
procedure Main is
   Obj : T;
begin
   Do_Test (Obj);
end Main;

Command: gnatmake -q -gnatVaM main.adb; ./main
Output:
  raised CONSTRAINT_ERROR : pkg.adb:20 invalid data

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

2017-10-14  Javier Miranda  

* checks.adb (Ensure_Valid): Do not skip adding the validity check on
renamings of objects that come from the sources.

Index: checks.adb
===
--- checks.adb  (revision 253753)
+++ checks.adb  (working copy)
@@ -5940,6 +5940,10 @@
   --  In addition, we force a check if Force_Validity_Checks is set
 
   elsif not Comes_From_Source (Expr)
+and then not
+  (Nkind (Expr) = N_Identifier
+and then Present (Renamed_Object (Entity (Expr)))
+and then Comes_From_Source (Renamed_Object (Entity (Expr
 and then not Force_Validity_Checks
 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
 or else Kill_Range_Check (Expr))

[Ada] Spurious ineffective use_type_clause warning on private type

[Pierre-Marie de Rodat]

This patch corrects an issue whereby a defaulted formal subprogram was not
being accounted for when checking for ineffective use_type_clauses on private
types used as generic actuals.


-- Source --


--  types.ads

package Types is
   type Enum_1 is private;
private
   type Enum_1 is (Red_1, Green_1, Blue_1);
end;

--  main.adb

with Types;
procedure Main is

   generic
  type Elem is private;
  with function "=" (L, R : Elem)
 return Boolean is <>;
   package Nested_4 is end;

   use type Types.Enum_1;
   package X is new Nested_4 (Types.Enum_1);
begin
   null;
end;


-- Compilation and output --


& gnatmake -q -gnatwu main.adb
main.adb:6:21: warning: function "=" is not referenced
main.adb:11:12: warning: package "X" is not referenced

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

2017-10-14  Justin Squirek  

* sem_ch8.adb (Analyze_Subprogram_Renaming): Modify condition that
triggers marking on formal subprograms.

Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 253753)
+++ sem_ch8.adb (working copy)
@@ -3644,19 +3644,16 @@
   --  and mark any use_package_clauses that affect the visibility of the
   --  implicit generic actual.
 
-  if From_Default (N)
-and then Is_Generic_Actual_Subprogram (New_S)
-and then Present (Alias (New_S))
+  if Is_Generic_Actual_Subprogram (New_S)
+and then (Is_Intrinsic_Subprogram (New_S) or else From_Default (N))
   then
- Mark_Use_Clauses (Alias (New_S));
+ Mark_Use_Clauses (New_S);
 
-  --  Check intrinsic operators used as generic actuals since they may
-  --  make a use_type_clause effective.
+ --  Handle overloaded subprograms
 
-  elsif Is_Generic_Actual_Subprogram (New_S)
-and then Is_Intrinsic_Subprogram (New_S)
-  then
- Mark_Use_Clauses (New_S);
+ if Present (Alias (New_S)) then
+Mark_Use_Clauses (Alias (New_S));
+ end if;
   end if;
end Analyze_Subprogram_Renaming;
 

[Ada] Fix performance regression of Ada.Numerics on 32-bit Windows

[Pierre-Marie de Rodat]

This fixes a run-time performance regression recently introduced on 32-bit
Windows for Ada.Numerics by an unrelated change that exposed an old defect of
the compiler on 32-bit Windows, namely that the Long_Long_Float type has got a
wrong alignment of 8 instead of the expected 4.

The following package:

package P is
   LLF : Long_Long_Float;
end P;

must yield the following output when compiled with -gnatR2 on 32-bit Windows:

Representation information for unit P (spec)


for Llf'Size use 96;
for Llf'Alignment use 4;

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

2017-10-14  Eric Botcazou  

* cstand.adb (Build_Float_Type): Move down Siz parameter, add Align
parameter and set the alignment of the type to Align.
(Copy_Float_Type): Adjust call to Build_Float_Type.
(Register_Float_Type): Add pragma Unreferenced for Precision.  Adjust
call to Build_Float_Type and do not set RM_Size and Alignment.

Index: cstand.adb
===
--- cstand.adb  (revision 253753)
+++ cstand.adb  (working copy)
@@ -62,15 +62,22 @@
---
 
procedure Build_Float_Type
- (E: Entity_Id;
-  Siz  : Int;
-  Rep  : Float_Rep_Kind;
-  Digs : Int);
+ (E : Entity_Id;
+  Digs  : Int;
+  Rep   : Float_Rep_Kind;
+  Siz   : Int;
+  Align : Int);
--  Procedure to build standard predefined float base type. The first
-   --  parameter is the entity for the type, and the second parameter is the
-   --  size in bits. The third parameter indicates the kind of representation
-   --  to be used. The fourth parameter is the digits value. Each type
+   --  parameter is the entity for the type. The second parameter is the
+   --  digits value. The third parameter indicates the representation to
+   --  be used for the type. The fourth parameter is the size in bits.
+   --  The fifth parameter is the alignment in storage units. Each type
--  is added to the list of predefined floating point types.
+   --
+   --  Note that both RM_Size and Esize are set to the specified size, i.e.
+   --  we do not set the RM_Size to the precision passed by the back end.
+   --  This is consistent with the semantics of 'Size specified in the RM
+   --  because we cannot pack components of the type tighter than this size.
 
procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Nat);
--  Procedure to build standard predefined signed integer subtype. The
@@ -189,10 +196,11 @@
--
 
procedure Build_Float_Type
- (E: Entity_Id;
-  Siz  : Int;
-  Rep  : Float_Rep_Kind;
-  Digs : Int)
+ (E : Entity_Id;
+  Digs  : Int;
+  Rep   : Float_Rep_Kind;
+  Siz   : Int;
+  Align : Int)
is
begin
   Set_Type_Definition (Parent (E),
@@ -201,10 +209,10 @@
 
   Set_Ekind  (E, E_Floating_Point_Type);
   Set_Etype  (E, E);
-  Set_Float_Rep (E, Rep);
+  Init_Digits_Value  (E, Digs);
+  Set_Float_Rep  (E, Rep);
   Init_Size  (E, Siz);
-  Set_Elem_Alignment (E);
-  Init_Digits_Value  (E, Digs);
+  Set_Alignment  (E, UI_From_Int (Align));
   Set_Float_Bounds   (E);
   Set_Is_Frozen  (E);
   Set_Is_Public  (E);
@@ -295,8 +303,9 @@
 
procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id) is
begin
-  Build_Float_Type (To, UI_To_Int (Esize (From)), Float_Rep (From),
-UI_To_Int (Digits_Value (From)));
+  Build_Float_Type
+(To, UI_To_Int (Digits_Value (From)), Float_Rep (From),
+ UI_To_Int (Esize (From)), UI_To_Int (Alignment (From)));
end Copy_Float_Type;
 
--
@@ -2065,15 +2074,17 @@
   Size  : Positive;
   Alignment : Natural)
is
+  pragma Unreferenced (Precision);
+  --  See Build_Float_Type for the rationale
+
   Ent : constant Entity_Id := New_Standard_Entity;
 
begin
   Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent);
   Make_Name (Ent, Name);
   Set_Scope (Ent, Standard_Standard);
-  Build_Float_Type (Ent, Int (Size), Float_Rep, Pos (Digs));
-  Set_RM_Size (Ent, UI_From_Int (Int (Precision)));
-  Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8)));
+  Build_Float_Type
+(Ent, Pos (Digs), Float_Rep, Int (Size), Int (Alignment / 8));
 
   if No (Back_End_Float_Types) then
  Back_End_Float_Types := New_Elmt_List;

Re: [PATCH v2] Python testcases to check DWARF output

[Pierre-Marie de Rodat]

On 09/05/2017 09:46 PM, Mike Stump wrote:

I've included the dwarf people on the cc list.  Seems like they may
have an opinion on the direction or the patch itself.  I was fine
with the patch from the larger testsuite perspective.

Good idea, thank you! And thank you for your feedback. :-)

--
Pierre-Marie de Rodat

[PATCH] [PR82155] Fix crash in dwarf2out_abstract_function

[Pierre-Marie de Rodat]

Hello,

This patch is an attempt to fix the crash reported in PR82155.

When generating a C++ class method for a class that is itself nested in
a class method, dwarf2out_early_global_decl currently leaves the
existing context DIE as it is if it already exists.  However, it is
possible that this call happens at a point where this context DIE is
just a declaration that is itself not located in its own context.

>From there, if dwarf2out_early_global_decl is not called on any of the
FUNCTION_DECL in the context chain, DIEs will be left badly scoped and
some (such as the nested method) will be removed by the type pruning
machinery.  As a consequence, dwarf2out_abstract_function will will
crash when called on the corresponding DECL because it asserts that the
DECL has a DIE.

This patch fixes this crash making dwarf2out_early_global_decl process
context DIEs the same way we process abstract origins for FUNCTION_DECL:
if the corresponding DIE exists but is only a declaration, call
dwarf2out_decl anyway on it so that it is turned into a more complete
DIE and so that it is relocated in the proper context.

Bootstrapped and regtested on x86_64-linux.  The crash this addresses is
present both on trunk and on the gcc-7 branch: I suggest we commit this
patch on both branches.  Ok to commit? Thank you in advance!

gcc/

PR debug/82155
* dwarf2out.c (dwarf2out_early_global_decl): Call dwarf2out_decl
on the FUNCTION_DECL function context if it has a DIE that is a
declaration.

gcc/testsuite/

* g++.dg/pr82155.C: New testcase.
---
 gcc/dwarf2out.c| 10 --
 gcc/testsuite/g++.dg/pr82155.C | 36 
 2 files changed, 44 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/g++.dg/pr82155.C

diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c
index 00d6d951ba3..4cfc9c186af 100644
--- a/gcc/dwarf2out.c
+++ b/gcc/dwarf2out.c
@@ -25500,10 +25500,16 @@ dwarf2out_early_global_decl (tree decl)
 so that all nested DIEs are generated at the proper scope in the
 first shot.  */
  tree context = decl_function_context (decl);
- if (context != NULL && lookup_decl_die (context) == NULL)
+ if (context != NULL)
{
+ dw_die_ref context_die = lookup_decl_die (context);
  current_function_decl = context;
- dwarf2out_decl (context);
+
+ /* Avoid emitting DIEs multiple times, but still process CONTEXT
+enough so that it lands in its own context.  This avoids type
+pruning issues later on.  */
+ if (context_die == NULL || is_declaration_die (context_die))
+   dwarf2out_decl (context);
}
 
  /* Emit an abstract origin of a function first.  This happens
diff --git a/gcc/testsuite/g++.dg/pr82155.C b/gcc/testsuite/g++.dg/pr82155.C
new file mode 100644
index 000..75d9b615f39
--- /dev/null
+++ b/gcc/testsuite/g++.dg/pr82155.C
@@ -0,0 +1,36 @@
+/* { dg-do compile { target c++11 } } */
+/* { dg-options "-g -O2" } */
+
+template  struct b { a c; };
+template  struct e { d *operator->(); };
+template  class h {
+public:
+  typedef e ag;
+};
+class i {
+protected:
+  i(int);
+};
+class j {
+  virtual void k(int) = 0;
+
+public:
+  int f;
+  void l() { k(f); }
+};
+struct m : i {
+  int cn;
+  m() : i(cn) {
+struct n : j {
+  n() {}
+  void k(int) {}
+};
+  }
+};
+struct o {
+  o() {
+for (h>::ag g;;)
+  g->c.c->l();
+  }
+};
+void fn1() { o(); }
-- 
2.14.1

[Ada] Review dependency tracking for Ada sources without -gnatd.n support

[Pierre-Marie de Rodat]

This patch will fix build glitches for parallelized Ada builds, which 
started to appear after the Makefile changes that came with the recent 
libgnat/libgnarl reorganization. Specifically, it fixes the detection of 
dependencies between Ada units for builds based on Ada compilers that 
don’t support the -gnatd.n flag.


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

2017-09-13  Nicolas Roche  <ro...@adacore.com>

* Make-lang.in: In the fallback mechanim, parse the associated
.ali file and try to guess the locations of dependencies.

--
Pierre-Marie de Rodat
Index: gcc/ada/gcc-interface/Make-lang.in
===
--- gcc/ada/gcc-interface/Make-lang.in  (revision 252081)
+++ gcc/ada/gcc-interface/Make-lang.in  (working copy)
@@ -106,14 +106,20 @@
 
 # Function that dumps the dependencies of an Ada object. Dependency only work
 # fully if the compiler support -gnatd.n. Otherwise a fallback mechanism is
-# used. The fallback mechanism add dependency on all ada sources in the same
-# directory as the original source.
+# used. The fallback mechanism parse the ali files to get the list of
+# dependencies and try to guess their location. If the location cannot be found
+# then the dependency is ignored.
 ifeq ($(findstring -gnatd.n,$(ALL_ADAFLAGS)),)
 ADA_DEPS=\
mkdir -p $(dir $@)/$(DEPDIR); \
(o="$@: $<"; \
-for d in $(dir $<)/*.ad[sb]; do \
-   o="$$o $$d"; \
+a="`echo $@ | sed -e 's/.o$$/.ali/'`"; \
+for d in `cat $$a | sed -ne 's;^D \([a-z0-9_\.-]*\).*;\1;gp'`; do \
+   for l in ada $(srcdir)/ada ada/libgnat $(srcdir)/ada/libgnat; do \
+  if test -f $$l/$$d; then \
+ o="$$o $$l/$$d"; \
+  fi; \
+   done; \
 done; \
 echo "$$o"; echo) \
 >$(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@))
@@ -121,11 +127,9 @@
 else
 ADA_DEPS=\
mkdir -p $(dir $@)/$(DEPDIR); \
-   (o="$@: $<"; \
-for d in `cat $@.gnatd.n`; do \
-   o="$$o $$d"; \
-done; \
-echo "$$o"; echo) \
+   (echo "$@: $< " | tr -d '\015' | tr -d '\n'; \
+cat $@.gnatd.n | tr -d '\015' | tr '\n' ' '; \
+echo; echo) \
>$(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@))
 ADA_OUTPUT_OPTION = $(OUTPUT_OPTION) > $@.gnatd.n
 endif
@@ -861,9 +865,11 @@
 
 ada.mostlyclean:
-$(RM) ada/*$(objext) ada/*.ali ada/b_gnat*.ads ada/b_gnat*.adb
+   -$(RM) ada/*$(objext).gnatd.n
-$(RM) ada/*$(coverageexts)
-$(RM) ada/sdefault.adb ada/stamp-sdefault ada/stamp-snames
-$(RMDIR) ada/tools
+   -$(RMDIR) ada/libgnat
-$(RM) gnatbind$(exeext) gnat1$(exeext)
 ada.clean:
 ada.distclean:

[Ada] vxworks: auto-registration of foreign threads

[Pierre-Marie de Rodat]

To make Ada tasks and C threads interoperate better, we have added some
functionality to Self. Suppose a C main program (with threads) calls an
Ada procedure and the Ada procedure calls the tasking runtime system.
Eventually, a call will be made to self. Since the call is not coming
from an Ada task, there will be no corresponding ATCB.

What we do in Self is to catch references that do not come from
recognized Ada tasks, and create an ATCB for the calling thread.

The new ATCB will be "detached" from the normal Ada task master
hierarchy, much like the existing implicitly created signal-server
tasks.

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

2017-09-13  Jerome Guitton  

* libgnarl/s-tpopsp__vxworks-tls.adb,
libgnarl/s-tpopsp__vxworks-rtp.adb, libgnarl/s-tpopsp__vxworks.adb
(Self): Register thread if task id is null.

Index: libgnarl/s-tpopsp__vxworks-tls.adb
===
--- libgnarl/s-tpopsp__vxworks-tls.adb  (revision 252075)
+++ libgnarl/s-tpopsp__vxworks-tls.adb  (working copy)
@@ -71,9 +71,29 @@
-- Self --
--
 
+   --  To make Ada tasks and C threads interoperate better, we have added some
+   --  functionality to Self. Suppose a C main program (with threads) calls an
+   --  Ada procedure and the Ada procedure calls the tasking runtime system.
+   --  Eventually, a call will be made to self. Since the call is not coming
+   --  from an Ada task, there will be no corresponding ATCB.
+
+   --  What we do in Self is to catch references that do not come from
+   --  recognized Ada tasks, and create an ATCB for the calling thread.
+
+   --  The new ATCB will be "detached" from the normal Ada task master
+   --  hierarchy, much like the existing implicitly created signal-server
+   --  tasks.
+
function Self return Task_Id is
+  Result : constant Task_Id := ATCB;
begin
-  return ATCB;
+  if Result /= null then
+ return Result;
+  else
+ --  If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+  end if;
end Self;
 
 end Specific;
Index: libgnarl/s-tpopsp__vxworks-rtp.adb
===
--- libgnarl/s-tpopsp__vxworks-rtp.adb  (revision 252075)
+++ libgnarl/s-tpopsp__vxworks-rtp.adb  (working copy)
@@ -72,9 +72,29 @@
-- Self --
--
 
+   --  To make Ada tasks and C threads interoperate better, we have added some
+   --  functionality to Self. Suppose a C main program (with threads) calls an
+   --  Ada procedure and the Ada procedure calls the tasking runtime system.
+   --  Eventually, a call will be made to self. Since the call is not coming
+   --  from an Ada task, there will be no corresponding ATCB.
+
+   --  What we do in Self is to catch references that do not come from
+   --  recognized Ada tasks, and create an ATCB for the calling thread.
+
+   --  The new ATCB will be "detached" from the normal Ada task master
+   --  hierarchy, much like the existing implicitly created signal-server
+   --  tasks.
+
function Self return Task_Id is
+  Result : constant Task_Id := To_Task_Id (tlsValueGet (ATCB_Key));
begin
-  return To_Task_Id (tlsValueGet (ATCB_Key));
+  if Result /= null then
+ return Result;
+  else
+ --  If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+  end if;
end Self;
 
 end Specific;
Index: libgnarl/s-tpopsp__vxworks.adb
===
--- libgnarl/s-tpopsp__vxworks.adb  (revision 252075)
+++ libgnarl/s-tpopsp__vxworks.adb  (working copy)
@@ -121,9 +121,29 @@
-- Self --
--
 
+   --  To make Ada tasks and C threads interoperate better, we have added some
+   --  functionality to Self. Suppose a C main program (with threads) calls an
+   --  Ada procedure and the Ada procedure calls the tasking runtime system.
+   --  Eventually, a call will be made to self. Since the call is not coming
+   --  from an Ada task, there will be no corresponding ATCB.
+
+   --  What we do in Self is to catch references that do not come from
+   --  recognized Ada tasks, and create an ATCB for the calling thread.
+
+   --  The new ATCB will be "detached" from the normal Ada task master
+   --  hierarchy, much like the existing implicitly created signal-server
+   --  tasks.
+
function Self return Task_Id is
+  Result : constant Task_Id := To_Task_Id (ATCB_Key);
begin
-  return To_Task_Id (ATCB_Key);
+  if Result /= null then
+ return Result;
+  else
+ --  If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+  end if;
end Self;
 
 end Specific;

[Ada] Ineffective pragma Suppress (Alignment_Check) on warning

[Pierre-Marie de Rodat]

On platforms that require strict alignment of memory accesses, the per-object
form of pragma Suppress (Alignment_Check) also disables the alignment warning
associated with the check.  That's not the case for the global form and this
change fixes the inconsistency.

Here's an example on a small package compiled with -gnatl:

Compiling: p.ads
Source file time stamp: 2017-08-07 10:41:19
Compiled at: 2017-08-07 15:19:52

 1. package P is
 2.
 3.   type Arr is array (1 .. 16) of Short_Integer;
 4.
 5.   A : Arr;
 6.
 7.   pragma Suppress (Alignment_Check);
 8.
 9.   F1 : Float;
10.   for F1 use at A'Address;  -- no warning
11.
12.   F2 : Float;
13.   for F2 use at A'Address;  -- warning
  |
>>> warning: specified address for "F2" may be inconsistent with
 alignment
>>> warning: program execution may be erroneous (RM 13.3(27))
>>> warning: alignment of "F2" is 4
>>> warning: alignment of "A" is 2

14.   pragma Unsuppress (Alignment_Check, F2);
15.
16.   pragma Unsuppress (Alignment_Check);
17.
18.   F3 : Float;
19.   for F3 use at A'Address;  -- warning
  |
>>> warning: specified address for "F3" may be inconsistent with
 alignment
>>> warning: program execution may be erroneous (RM 13.3(27))
>>> warning: alignment of "F3" is 4
>>> warning: alignment of "A" is 2

20.
21.   F4 : Float;
22.   for F4 use at A'Address;  -- no warning
23.   pragma Suppress (Alignment_Check, F4);
24.
25. end P;

 25 lines: No errors, 8 warnings

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

2017-09-13  Eric Botcazou  

* sem_ch13.adb (Register_Address_Clause_Check): New procedure to save
the suppression status of Alignment_Check on the current scope.
(Alignment_Checks_Suppressed): New function to use the saved instead of
the current suppression status of Alignment_Check.
(Address_Clause_Check_Record): Add Alignment_Checks_Suppressed field.
(Analyze_Attribute_Definition_Clause): Instead of manually appending to
the table, call Register_Address_Clause_Check.
(Validate_Address_Clauses): Call Alignment_Checks_Suppressed on the
recorded address clause instead of its entity.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 252075)
+++ sem_ch13.adb(working copy)
@@ -203,6 +203,15 @@
--  renaming_as_body. For tagged types, the specification is one of the
--  primitive specs.
 
+   procedure Register_Address_Clause_Check
+ (N   : Node_Id;
+  X   : Entity_Id;
+  A   : Uint;
+  Y   : Entity_Id;
+  Off : Boolean);
+   --  Register a check for the address clause N. The rest of the parameters
+   --  are in keeping with the components of Address_Clause_Check_Record below.
+
procedure Resolve_Iterable_Operation
  (N  : Node_Id;
   Cursor : Entity_Id;
@@ -318,6 +327,11 @@
 
   Off : Boolean;
   --  Whether the address is offset within Y in the second case
+
+  Alignment_Checks_Suppressed : Boolean;
+  --  Whether alignment checks are suppressed by an active scope suppress
+  --  setting. We need to save the value in order to be able to reuse it
+  --  after the back end has been run.
end record;
 
package Address_Clause_Checks is new Table.Table (
@@ -328,6 +342,26 @@
  Table_Increment  => 200,
  Table_Name   => "Address_Clause_Checks");
 
+   function Alignment_Checks_Suppressed
+ (ACCR : Address_Clause_Check_Record) return Boolean;
+   --  Return whether the alignment check generated for the address clause
+   --  is suppressed.
+
+   -
+   -- Alignment_Checks_Suppressed --
+   -
+
+   function Alignment_Checks_Suppressed
+ (ACCR : Address_Clause_Check_Record) return Boolean
+   is
+   begin
+  if Checks_May_Be_Suppressed (ACCR.X) then
+ return Is_Check_Suppressed (ACCR.X, Alignment_Check);
+  else
+ return ACCR.Alignment_Checks_Suppressed;
+  end if;
+   end Alignment_Checks_Suppressed;
+
-
-- Adjust_Record_For_Reverse_Bit_Order --
-
@@ -5047,8 +5081,8 @@
and then not Is_Generic_Type (Etype (U_Ent))
and then Address_Clause_Overlay_Warnings
  then
-Address_Clause_Checks.Append
-  ((N, U_Ent, No_Uint, O_Ent, Off));
+Register_Address_Clause_Check
+  (N, 

[Ada] Undefined symbol at link time due to Disable_Controlled

[Pierre-Marie de Rodat]

This patch reimplements aspect Disable_Controlled to plug the following holes
in its original implementation:

   * The aspect may appear without an expression in which case the aspect
 defaults to True, however the compiler would crash due to the lack of
 expression.

   * If the expression is present, then it should be static, however the
 compiler would silently accept a non-static expression.

   * Various types that derive and/or contain a component of a type subject
 to the aspect are now properly handled.

The patch also modifies predicate Is_Controlled to indicate whether a type is
derived from [Limited_]Controlled AND NOT subject to aspect Disable_Controlled.
This modification allows the semantics of the aspect to automatically perculate
to derived types and/or composite types with components subject to the aspect.
As a result, the finalization mechanism now properly handles such types and
generates the appropriate Deep_Adjust, Deep_Initialize, and Deep_Finalize
primitives.


-- Source --


--  factorial.ads

function Factorial (Val : Natural) return Natural;

--  factorial.adb

function Factorial (Val : Natural) return Natural is
begin
   if Val > 1 then
  return Val * Factorial (Val - 1);
   end if;

   return 1;
end Factorial;

--  semantics.ads

with Ada.Finalization; use Ada.Finalization;
with Factorial;

package Semantics is
   generic
  Flag : Boolean;
  Int  : Integer;

   package Nested_Gen is
  type Ctrl_Rec_1 is new Controlled with null record
with Disable_Controlled => Int;  --  Error

  type Ctrl_Rec_2 is new Limited_Controlled with null record
with Disable_Controlled => Factorial (3) = 6;--  N/A

  type Ctrl_Rec_3 is new Controlled with null record
with Disable_Controlled => Flag; --  OK
   end Nested_Gen;

   subtype Small_Int is Integer range 1 .. 10
 with Disable_Controlled;--  Error

   type Rec is null record
 with Disable_Controlled => False;   --  Error

   type Ctrl_Rec_1 is new Controlled with null record
 with Disable_Controlled => "what?"; --  Error

   type Ctrl_Rec_2 is new Limited_Controlled with null record
 with Disable_Controlled => Factorial (3) = 6;   --  Error

   type Ctrl_Rec_3 is new Controlled with null record
 with Disable_Controlled => True;--  OK

   Is_True : constant Boolean := True;

   type Ctrl_Rec_4 is new Limited_Controlled with null record
 with Disable_Controlled => Is_True; --  OK
end Semantics;

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   generic
  Flag : Boolean;

   package Gen is
  type Ctrl is new Controlled with record
 Id : Natural;
  end record;

  procedure Adjust (Obj : in out Ctrl);
  procedure Finalize (Obj : in out Ctrl);
  procedure Initialize (Obj : in out Ctrl);

  type Ctrl_DC is new Controlled with record
 Id : Natural;
  end record
with Disable_Controlled => Flag;

  procedure Adjust (Obj : in out Ctrl_DC);
  procedure Finalize (Obj : in out Ctrl_DC);
  procedure Initialize (Obj : in out Ctrl_DC);

  type Ctrl_Ctrl_DC is new Controlled with record
 Id   : Natural;
 Comp : Ctrl_DC;
  end record;

  procedure Adjust (Obj : in out Ctrl_Ctrl_DC);
  procedure Finalize (Obj : in out Ctrl_Ctrl_DC);
  procedure Initialize (Obj : in out Ctrl_Ctrl_DC);

  type Ctrl_DC_Ctrl is new Controlled with record
 Id   : Natural;
 Comp : Ctrl;
  end record
with Disable_Controlled => True;

  procedure Adjust (Obj : in out Ctrl_DC_Ctrl);
  procedure Finalize (Obj : in out Ctrl_DC_Ctrl);
  procedure Initialize (Obj : in out Ctrl_DC_Ctrl);

  type Ctrl_DC_Ctrl_DC is new Controlled with record
 Id   : Natural;
 Comp : Ctrl_DC;
  end record
with Disable_Controlled;

  procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC);
  procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC);
  procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC);

  type Rec_Ctrl_DC is record
 Comp : Ctrl_DC;
  end record;
   end Gen;

   generic
  Typ_Name : String;
  type Typ is private;
   procedure Test;

   type Ctrl is new Controlled with record
  Id : Natural;
   end record;

   procedure Adjust (Obj : in out Ctrl);
   procedure Finalize (Obj : in out Ctrl);
   procedure Initialize (Obj : in out Ctrl);

   type Ctrl_DC is new Controlled with record
  Id : Natural;
   end record
 with Disable_Controlled => True;

   procedure Adjust (Obj : in out Ctrl_DC);
   procedure Finalize (Obj : in out Ctrl_DC);
   procedure Initialize (Obj : in out Ctrl_DC);

   type Ctrl_Ctrl_DC is new 

[Ada] Build in place for nonlimited types

[Pierre-Marie de Rodat]

First cut at build-in-place for nonlimited types.
This is a work in progress; the build-in-place
support is currently disabled.

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

2017-09-29  Bob Duff  

* exp_ch6.adb (Expand_Call_Helper): Handle case of build-in-place
functions returning nonlimited types. Allow for qualified expressions
and type conversions.
(Expand_N_Extended_Return_Statement): Correct the computation of
Func_Bod to allow for child units.
(Expand_Simple_Function_Return): Remove assumption that b-i-p implies
limited (initialization of In_Place_Expansion), and implies >= Ada
2005.
(Is_Build_In_Place_Result_Type): New function to accompany
Is_Build_In_Place_Function and Is_Build_In_Place_Function_Call, because
sometimes we just have the type on our hands, not the function.  For
now, does the same thing as the old version, so build-in-place is
disabled for nonlimited types, except that you can use -gnatd.9 to
enable it.
* exp_ch6.ads (Is_Build_In_Place_Result_Type): New function to
accompany Is_Build_In_Place_Function and
Is_Build_In_Place_Function_Call, because sometimes we just have the
type on our hands, not the function.
(Make_Build_In_Place_Call_In_...): Handle nonlimited build-in-place
cases.
(Make_Build_In_Place_Call_In_Object_Declaration): Remove the
questionable code at the end that was setting the Etype.
* exp_aggr.adb (Is_Build_In_Place_Aggregate_Return): New function to
determine whether "return (...agg...);" is returning from a
build-in-place function.
(Initialize_Ctrl_Array_Component, Initialize_Ctrl_Record_Component):
Remove assumption that b-i-p implies limited (initialization of
In_Place_Expansion).
(Build_Record_Aggr_Code): AI-287: fix comment; it can't be wrapped in
an unchecked conversion.  Add assertions.
(Convert_Aggr_In_Object_Decl): Establish_Transient_Scope -- no need for
secondary stack here, just because the type needs finalization.  That
code is obsolete.
(Convert_To_Assignments): Only set Unc_Decl if Nkind (N) = N_Aggregate.
For "return (...agg...);" don't assume b-i-p implies limited.
Needs_Finalization does not imply secondary stack.
(Expand_Array_Aggregate): Named notation.  Reverse the sense of
Component_OK_For_Backend -- more readability with fewer double
negatives.
* exp_attr.adb (Expand_N_Attribute_Reference): Remove assumptions that
b-i-p implies >= Ada 2005.
* exp_ch3.adb (Expand_N_Object_Declaration): Remove assumptions that
b-i-p implies >= Ada 2005.  Remove Adjust if we're building the return
object of an extended return statement in place.
* exp_ch4.adb (Expand_Allocator_Expression, Expand_N_Indexed_Component,
Expand_N_Selected_Component, Expand_N_Slice): Remove assumptions that
b-i-p implies >= Ada 2005.
* exp_ch5.adb (Expand_N_Assignment_Statement): Remove assumption that
b-i-p implies >= Ada 2005.
* exp_ch7.adb: Comment fix.
* exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Remove
assumptions that b-i-p implies >= Ada 2005.
* exp_disp.adb (Expand_Interface_Actuals): Remove assumptions that
b-i-p implies >= Ada 2005.
* exp_util.adb (Build_Allocate_Deallocate_Proc): Look at Storage_Pool
(Expr), in case Pool_Id is not set.
(Initialized_By_Aliased_BIP_Func_Call): Handle case where the call is
qualified or converted.
(Is_Secondary_Stack_BIP_Func_Call): Don't check if Nkind (Selector_Name
(Param)) = N_Identifier; that's all it could be.
* sinfo.ads: Comment fixes.
* snames.ads-tmpl: Comment fixes.
* debug.adb: Add flag gnatd.9, to enable the build-in-place machinery.

Index: exp_aggr.adb
===
--- exp_aggr.adb(revision 253285)
+++ exp_aggr.adb(working copy)
@@ -175,6 +175,10 @@
-- Local subprograms for Record Aggregate Expansion --
--
 
+   function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
+   --  True if N is an aggregate (possibly qualified or converted) that is
+   --  being returned from a build-in-place function.
+
function Build_Record_Aggr_Code
  (N   : Node_Id;
   Typ : Entity_Id;
@@ -186,10 +190,9 @@
--  types.
 
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
-   --  N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
-   --  aggregate (which can only be a record type, this procedure is only used
-   --  for record types). Transform the given aggregate into a sequence of
-   --  assignments performed component 

[Ada] Avoid single colon in comment markup

[Pierre-Marie de Rodat]

This change allows our style-checker to implement a heuristic to detect
either only typed one ':' or mistyped one of the characters, causing the
entire markup block to disappear as it is then unexpectedly being
treated as a comment instead.

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

2017-09-29  Joel Brobecker  

* doc/gnat_ugn/building_executable_programs_with_gnat.rst,
doc/gnat_ugn/the_gnat_compilation_model.rst: Avoid use of single colon
in comment markup.
* gnat_ugn.texi: Regenerate.

Index: doc/gnat_ugn/building_executable_programs_with_gnat.rst
===
--- doc/gnat_ugn/building_executable_programs_with_gnat.rst (revision 
253283)
+++ doc/gnat_ugn/building_executable_programs_with_gnat.rst (working copy)
@@ -559,7 +559,7 @@
   -f, it is equivalent to calling the compiler directly. Note that using
   -u with a project file and no main has a special meaning.
 
-.. --Comment:
+.. --Comment
   (See :ref:`Project_Files_and_Main_Subprograms`.)
 
 
Index: doc/gnat_ugn/the_gnat_compilation_model.rst
===
--- doc/gnat_ugn/the_gnat_compilation_model.rst (revision 253283)
+++ doc/gnat_ugn/the_gnat_compilation_model.rst (working copy)
@@ -1569,7 +1569,7 @@
 If you are using project file, a separate mechanism is provided using
 project attributes.
 
-.. --Comment:
+.. --Comment
See :ref:`Specifying_Configuration_Pragmas` for more details.
 
 
Index: gnat_ugn.texi
===
--- gnat_ugn.texi   (revision 253285)
+++ gnat_ugn.texi   (working copy)
@@ -3193,7 +3193,7 @@
 If you are using project file, a separate mechanism is provided using
 project attributes.
 
-@c --Comment:
+@c --Comment
 @c See :ref:`Specifying_Configuration_Pragmas` for more details.
 
 @node Generating Object Files,Source Dependencies,Configuration Pragmas,The 
GNAT Compilation Model
@@ -7925,7 +7925,7 @@
 -u with a project file and no main has a special meaning.
 @end table
 
-@c --Comment:
+@c --Comment
 @c (See :ref:`Project_Files_and_Main_Subprograms`.)
 
 @geindex -U (gnatmake)

[Ada] Misleading warning when no read access for source file

[Pierre-Marie de Rodat]

This patch corrects an issue whereby source files that did not have read
permissions were incorrectly referred to as "not found'. Now, these different
cases are explicitly identified and warned about properly.


-- Source --


--  toto.c

void toto(void)
{
}

--  hello.adb

with Ada.Text_IO; use Ada.Text_IO;
procedure Hello is
begin
   Put_Line ("Hello, world!");
end Hello;


-- Compilation and output --


& chmod a-r hello.adb
& gcc -c hello.adb
& chmod a+r hello.adb
& chmod a-r toto.c
& gcc -c toto.c
& chmod a+r toto.c

no read access for file "hello.adb"
cc1: fatal error: toto.c: Permission denied
compilation terminated.

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

2017-09-29  Justin Squirek  

* ali-util.adb, comperr.adb, errout.adb, fmap.adb, fname-sf.adb,
frontend.adb, lib-xref-spark_specific.adb, gnat1drv.adb, gnatls.adb,
lib.adb, lib-load.adb, lib-writ.adb, prepcomp.adb, sinput-d.adb,
sinput-l.adb, sprint.adb, targparm.adb: Update comparison for checking
source file status and error message and/or call to Read_Source_File.
* libgnat/s-os_lib.ads: Add new potential value constant for
uninitialized file descriptors.
* osint.adb, osint.ads (Read_Source_File): Add extra parameter to
return result of IO to encompass a read access failure in addition to a
file-not-found error.

Index: lib.adb
===
--- lib.adb (revision 253283)
+++ lib.adb (working copy)
@@ -626,7 +626,7 @@
 Source_File := Get_Source_File_Index (S);
 
 if Unwind_Instances then
-   while Template (Source_File) /= No_Source_File loop
+   while Template (Source_File) > No_Source_File loop
   Source_File := Template (Source_File);
end loop;
 end if;
Index: frontend.adb
===
--- frontend.adb(revision 253283)
+++ frontend.adb(working copy)
@@ -126,7 +126,7 @@
 
--  Return immediately if the main source could not be found
 
-   if Sinput.Main_Source_File = No_Source_File then
+   if Sinput.Main_Source_File <= No_Source_File then
   return;
end if;
 
@@ -167,7 +167,7 @@
 
  --  Case of gnat.adc file present
 
- if Source_gnat_adc /= No_Source_File then
+ if Source_gnat_adc > No_Source_File then
 --  Parse the gnat.adc file for configuration pragmas
 
 Initialize_Scanner (No_Unit, Source_gnat_adc);
@@ -213,7 +213,7 @@
 
   Source_Config_File := Load_Config_File (Config_Name);
 
-  if Source_Config_File = No_Source_File then
+  if Source_Config_File <= No_Source_File then
  Osint.Fail
("cannot find configuration pragmas file "
 & Config_File_Names (Index).all);
Index: lib-xref-spark_specific.adb
===
--- lib-xref-spark_specific.adb (revision 253283)
+++ lib-xref-spark_specific.adb (working copy)
@@ -249,7 +249,7 @@
   --  Source file could be inexistant as a result of an error, if option
   --  gnatQ is used.
 
-  if File = No_Source_File then
+  if File <= No_Source_File then
  return;
   end if;
 
Index: sprint.adb
===
--- sprint.adb  (revision 253283)
+++ sprint.adb  (working copy)
@@ -3752,7 +3752,7 @@
   --  Ignore if there is no current source file, or we're not in dump
   --  source text mode, or if in freeze actions.
 
-  if Current_Source_File /= No_Source_File
+  if Current_Source_File > No_Source_File
 and then Dump_Source_Text
 and then Freeze_Indent = 0
   then
Index: fmap.adb
===
--- fmap.adb(revision 253283)
+++ fmap.adb(working copy)
@@ -175,6 +175,7 @@

 
procedure Initialize (File_Name : String) is
+  FD  : File_Descriptor;
   Src : Source_Buffer_Ptr;
   Hi  : Source_Ptr;
 
@@ -297,10 +298,14 @@
 
begin
   Empty_Tables;
-  Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, Config);
+  Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, FD, Config);
 
   if Null_Source_Buffer_Ptr (Src) then
- Write_Str ("warning: could not read mapping file """);
+ if FD = Null_FD then
+Write_Str ("warning: could not locate mapping file """);
+ else
+Write_Str ("warning: no read access for mapping file """);
+ end if;
  Write_Str (File_Name);
  Write_Line ();
  No_Mapping_File := True;
Index: gnatls.adb

[Ada] Spurious error in nested generic containing expression function

[Pierre-Marie de Rodat]

This patch removes spurious visibility errors from the instantiation of a
generic package nested within another generic, when the inner package
contains an expression function that is the completion of a visible
function of that package, and the expression includes an object of a
tagged type local to the generic.

No small example available.

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

2017-09-29  Ed Schonberg  

* sem_ch6.adb (Analyze_Expression_Function): Do not emit freeze nodes
for types in expression if the function is within a generic unit.
* sem_res.adb (Resolve): In a generic context do not freeze an
expression, unless it is an entity. This exception is solely for the
purpose of detecting illegal uses of deferred constants in generic
units.
* sem_res.adb: Minor reformatting.

Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 253283)
+++ sem_ch6.adb (working copy)
@@ -568,8 +568,11 @@
  --  Note that we cannot defer this freezing to the analysis of the
  --  expression itself, because a freeze node might appear in a nested
  --  scope, leading to an elaboration order issue in gigi.
+ --  As elsewhere, we do not emit freeze nodes within a generic unit.
 
- Freeze_Expr_Types (Def_Id);
+ if not Inside_A_Generic then
+Freeze_Expr_Types (Def_Id);
+ end if;
 
  --  For navigation purposes, indicate that the function is a body
 
Index: sem_res.adb
===
--- sem_res.adb (revision 253283)
+++ sem_res.adb (working copy)
@@ -3070,8 +3070,15 @@
  --  Here we are resolving the corresponding expanded body, so we do
  --  need to perform normal freezing.
 
- Freeze_Expression (N);
+ --  As elsewhere we do not emit freeze node within a generic. We make
+ --  an exception for entities that are expressions, only to detect
+ --  misuses of deferred constants and preserve the output of various
+ --  tests.
 
+ if not Inside_A_Generic or else Is_Entity_Name (N) then
+Freeze_Expression (N);
+ end if;
+
  --  Now we can do the expansion
 
  Expand (N);

[Ada] Compiler hangs on evaluation of use-clause within package context

[Pierre-Marie de Rodat]

Due to the installation order of packages within a context clause it is
possible to create circularities within the Prev_Use_Clause clain. This patch
corrects this issue by identifying this case through the use of an extra check.

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

2017-09-29  Justin Squirek  

* sem_ch8.adb (Analyze_Use_Package): Add sanity check to avoid
circularities in the use-clause chain.

Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 253285)
+++ sem_ch8.adb (working copy)
@@ -3782,9 +3782,10 @@
   --  before setting its previous use clause.
 
   if Ekind (Pack) = E_Package
- and then Present (Current_Use_Clause (Pack))
- and then Current_Use_Clause (Pack) /= N
- and then No (Prev_Use_Clause (N))
+and then Present (Current_Use_Clause (Pack))
+and then Current_Use_Clause (Pack) /= N
+and then No (Prev_Use_Clause (N))
+and then Prev_Use_Clause (Current_Use_Clause (Pack)) /= N
   then
  Set_Prev_Use_Clause (N, Current_Use_Clause (Pack));
   end if;

[Ada] Pragma Unchecked_Union on derived discriminated type

[Pierre-Marie de Rodat]

The compiler reports an spurious error processing a derived type
of a non-tagged record type that has discriminants, pragma
Unchecked_Union and pragma Convention C.

After this patch the following test compiles silently.

procedure Conversion is
   type small_array is array (0 .. 2) of Integer;
   type big_array   is array (0 .. 3) of Integer;

   type small_record is record
  field1 : aliased Integer := 0;
  field2 : aliased small_array := (0, 0, 0);
   end record;

   type big_record is record
  field1 : aliased Integer   := 0;
  field2 : aliased big_array := (0, 0, 0, 0);
   end record;

   type myUnion (discr : Integer := 0) is record
  case discr is
 when 0 =>
record1 : aliased small_record;
 when others =>
record2 : aliased big_record;
  end case;
   end record;

   type UU_myUnion3 (discr : Integer := 0) is new myUnion (discr); -- Test
   pragma Unchecked_Union (UU_myUnion3);
   pragma Convention (C, UU_myUnion3);

   procedure Convert (A : in UU_myUnion3; B : out UU_myUnion3);
   pragma Import (C, Convert);

begin
   null;
end Conversion;

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

gcc/ada/

2017-09-29  Javier Miranda  

* sem_ch3.adb (Replace_Components): Update references to discriminants
located in variant parts inherited from the parent type.

gcc/testsuite/

2017-09-29  Javier Miranda  

* gnat.dg/unchecked_union2.adb: New testcase.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 253283)
+++ sem_ch3.adb (working copy)
@@ -21932,6 +21932,17 @@
Next_Discriminant (Comp);
 end loop;
 
+ elsif Nkind (N) = N_Variant_Part then
+Comp := First_Discriminant (Typ);
+while Present (Comp) loop
+   if Chars (Comp) = Chars (Name (N)) then
+  Set_Entity (Name (N), Comp);
+  exit;
+   end if;
+
+   Next_Component (Comp);
+end loop;
+
  elsif Nkind (N) = N_Component_Declaration then
 Comp := First_Component (Typ);
 while Present (Comp) loop
Index: ../testsuite/gnat.dg/unchecked_union2.adb
===
--- ../testsuite/gnat.dg/unchecked_union2.adb   (revision 0)
+++ ../testsuite/gnat.dg/unchecked_union2.adb   (revision 0)
@@ -0,0 +1,35 @@
+--  { dg-do compile }
+
+procedure Unchecked_Union2 is
+   type small_array is array (0 .. 2) of Integer;
+   type big_array   is array (0 .. 3) of Integer;
+
+   type small_record is record
+  field1 : aliased Integer := 0;
+  field2 : aliased small_array := (0, 0, 0);
+   end record;
+
+   type big_record is record
+  field1 : aliased Integer   := 0;
+  field2 : aliased big_array := (0, 0, 0, 0);
+   end record;
+
+   type myUnion (discr : Integer := 0) is record
+  case discr is
+ when 0 =>
+record1 : aliased small_record;
+ when others =>
+record2 : aliased big_record;
+  end case;
+   end record;
+
+   type UU_myUnion3 (discr : Integer := 0) is new myUnion (discr); -- Test
+   pragma Unchecked_Union (UU_myUnion3);
+   pragma Convention (C, UU_myUnion3);
+
+   procedure Convert (A : in UU_myUnion3; B : out UU_myUnion3);
+   pragma Import (C, Convert);
+
+begin
+   null;
+end Unchecked_Union2;

[Ada] Crash on illegal use of iterated component association

[Pierre-Marie de Rodat]

An iterated component association is an Ada2020 extension that simplifies
the construction of array aggregates.  This patch properly rejects the use
of this construct as a named association in an aggregate for a record type.

compiling
   gcc -c -gnat2020 klurigt-m2.adb

must yield:

   klurigt-m2.adb:11:12:
 iterated component association can only appear in an array aggregate
   compilation abandoned

---
with Klurigt.Conv;use Klurigt.Conv;
procedure Klurigt.M2 is

   function Bar_Of
 (Bar : in Bar_Type)
  return My_Bar_Type
   is
   begin
  return Result : constant My_Bar_Type
:= (for Index in 1 .. Foo_Index_Type (Bar.Foos'Last) =>
Foo_Of (Bar.Foos (Foo_Index_Type (Index
  do
 null;
  end return; 
   end Bar_Of;
begin
   null;
end Klurigt.M2;
---
package Klurigt is
   type Foo_Type
   is record
  Kalle : Natural := 0;
  Olle  : Integer := 0;
   end record;

   type Foo_Index_Type is new Natural;

   MAX_FOO_ARRAY_SIZE : constant Foo_Index_Type := 10;

   type Foo_Array_Type is array (1 .. MAX_FOO_ARRAY_SIZE) of Foo_Type;

   type Bar_Type
   is record
  Foos : Foo_Array_Type;
   end record;

   type My_Natural_Type is new Natural;
   type My_Integer_Type is new Integer;

   type My_Foo_Type
   is record
  Kalle : My_Natural_Type := 0;
  Olle  : My_Integer_Type := 0;
   end record;

   type My_Foo_Array_Index_Type is new Integer;

   MAX_MY_FOO_ARRAY_SIZE : constant My_Foo_Array_Index_Type := 10;

   type My_Foo_Array_Type is array (1 .. MAX_MY_FOO_ARRAY_SIZE) of My_Foo_Type;

   type My_Bar_Type
   is record
  Foos : My_Foo_Array_Type;
   end record;
end Klurigt;
---
package Klurigt.Conv is
   function Foo_Of
 (Foo : in Foo_Type)
  return My_Foo_Type
   is (Kalle => My_Natural_Type (Foo.Kalle),
   Olle  => My_Integer_Type (Foo.Olle));
end Klurigt.Conv;

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

2017-09-29  Ed Schonberg  

* sem_aggr.adb (Resolve_Record_Aggregate): Reject the use of an
iterated component association in an aggregate for a record type.

Index: sem_aggr.adb
===
--- sem_aggr.adb(revision 253283)
+++ sem_aggr.adb(working copy)
@@ -4108,15 +4108,22 @@
  begin
 Assoc := First (Component_Associations (N));
 while Present (Assoc) loop
-   if List_Length (Choices (Assoc)) > 1 then
-  Check_SPARK_05_Restriction
-("component association in record aggregate must "
- & "contain a single choice", Assoc);
-   end if;
+   if Nkind (Assoc) = N_Iterated_Component_Association then
+  Error_Msg_N ("iterated component association can only "
+& "appear in an array aggregate", N);
+  raise Unrecoverable_Error;
 
-   if Nkind (First (Choices (Assoc))) = N_Others_Choice then
-  Check_SPARK_05_Restriction
-("record aggregate cannot contain OTHERS", Assoc);
+   else
+  if List_Length (Choices (Assoc)) > 1 then
+ Check_SPARK_05_Restriction
+   ("component association in record aggregate must "
+& "contain a single choice", Assoc);
+  end if;
+
+  if Nkind (First (Choices (Assoc))) = N_Others_Choice then
+ Check_SPARK_05_Restriction
+   ("record aggregate cannot contain OTHERS", Assoc);
+  end if;
end if;
 
Assoc := Next (Assoc);

[Ada] Copy of Unchecked_Union derived discriminated types

[Pierre-Marie de Rodat]

The compiler crashes processing an assignment to a discriminated
record type that has pragma Unchecked_Union and Convention C and
is a derivation of a non-tagged record type with discriminants.

After this patch the following test compiles silently.

procedure Conversion is
   type small_array is array (0 .. 2) of Integer;
   type big_array   is array (0 .. 3) of Integer;

   type small_record is record
  field1 : aliased Integer := 0;
  field2 : aliased small_array := (0, 0, 0);
   end record;

   type big_record is record
  field1 : aliased Integer   := 0;
  field2 : aliased big_array := (0, 0, 0, 0);
   end record;

   type myUnion (discr : Integer := 0) is record
  case discr is
 when 0 =>
record1 : aliased small_record;
 when others =>
record2 : aliased big_record;
  end case;
   end record;

   type UU_myUnion1 is new myUnion;
   pragma Unchecked_Union (UU_myUnion1);
   pragma Convention (C, UU_myUnion1);

   procedure Convert (A : in myUnion; B : out UU_myUnion1) is
  L : UU_myUnion1 := UU_myUnion1 (A);  --  Test
   begin
  B := L;
   end Convert;

begin
   null;
end Conversion;

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

gcc/ada/

2017-09-29  Javier Miranda  

* exp_ch5.adb (Expand_Assign_Record): Do not generate code to copy
discriminants if the target is an Unchecked_Union record type.

gcc/testsuite/

2017-09-29  Javier Miranda  

* gnat.dg/unchecked_union3.adb: New testcase.
Index: exp_ch5.adb
===
--- exp_ch5.adb (revision 253283)
+++ exp_ch5.adb (working copy)
@@ -1577,7 +1577,14 @@
  --  suppressed in this case). It is unnecessary but harmless in
  --  other cases.
 
- if Has_Discriminants (L_Typ) then
+ --  Special case: no copy if the target has no discriminants.
+
+ if Has_Discriminants (L_Typ)
+   and then Is_Unchecked_Union (Base_Type (L_Typ))
+ then
+null;
+
+ elsif Has_Discriminants (L_Typ) then
 F := First_Discriminant (R_Typ);
 while Present (F) loop
 
Index: ../testsuite/gnat.dg/unchecked_union3.adb
===
--- ../testsuite/gnat.dg/unchecked_union3.adb   (revision 0)
+++ ../testsuite/gnat.dg/unchecked_union3.adb   (revision 0)
@@ -0,0 +1,38 @@
+--  { dg-do compile }
+
+procedure Unchecked_Union3 is
+   type small_array is array (0 .. 2) of Integer;
+   type big_array   is array (0 .. 3) of Integer;
+
+   type small_record is record
+  field1 : aliased Integer := 0;
+  field2 : aliased small_array := (0, 0, 0);
+   end record;
+
+   type big_record is record
+  field1 : aliased Integer   := 0;
+  field2 : aliased big_array := (0, 0, 0, 0);
+   end record;
+
+   type myUnion (discr : Integer := 0) is record
+  case discr is
+ when 0 =>
+record1 : aliased small_record;
+ when others =>
+record2 : aliased big_record;
+  end case;
+   end record;
+
+   type UU_myUnion1 is new myUnion;
+   pragma Unchecked_Union (UU_myUnion1);
+   pragma Convention (C, UU_myUnion1);
+
+   procedure Convert (A : in myUnion; B : out UU_myUnion1) is
+  L : UU_myUnion1 := UU_myUnion1 (A);  --  Test
+   begin
+  B := L;
+   end Convert;
+
+begin
+   null;
+end Unchecked_Union3;

Re: [Ada] Use the Monotonic Clock on Linux

[Pierre-Marie de Rodat]

On 09/25/2017 02:36 PM, Duncan Sands wrote:

+    --  The most recent calls to clock_gettime were more better.


were more better -> were better


Yes, we fixed that in a latter commit. :-)

https://gcc.gnu.org/git/?p=gcc.git;a=commitdiff;h=2a6c14a68616dfb8d8578bb8692c5e05de4aade3#patch3

--
Pierre-Marie de Rodat

Re: [Ada] Improve performance of 'Image with enumeration types.

[Pierre-Marie de Rodat]

On 09/25/2017 02:47 PM, Duncan Sands wrote:
it looks like this is in essence inlining the run-time library routine.  
In which case, shouldn't you only do it if inlining is enabled?  For 
example, it seems rather odd to do this if compiling with -Os.


Actually, measurements showed that this instance of inlining is a win 
for both performance and code size, so it’s a good candidate even for 
-Os. Note that we inline string concatenation routines for the same reason.


--
Pierre-Marie de Rodat

[Ada] Crash on classwide precondition for interface operation

[Pierre-Marie de Rodat]

This patch fixes a crash on a classwide precondition on an interface
primitive with an controlling access parameter, when the precondition is
a call that contains a reference to that formal.

The following must execute quietly:

   gnatmake -q main
   main

---
with Conditional_Interfaces;
with Conditional_Objects;

procedure Main is

   D  : aliased Conditional_Interfaces.Data_Object;
   O  : aliased Conditional_Objects.Object;
   IA : not null access Conditional_Interfaces.Conditional_Interface'Class :=
  O'Access;
   I  : Conditional_Interfaces.Conditional_Interface'Class renames
  Conditional_Interfaces.Conditional_Interface'Class (O);
begin
   O.Do_Stuff;
   O.Do_Stuff_Access;
   O.Update_Data (D'Unchecked_Access);
   IA.Do_Stuff;
   IA.Do_Stuff_Access;
   IA.Update_Data (D'Unchecked_Access); --
 Commenting this line prevents the error.
   I.Do_Stuff;

   -- These also raises an error
   --  "call to abstract function must be dispatching" which seems incorrect
   --  I.Do_Stuff_Access;
   --  I.Update_Data (D'Unchecked_Access);
end Main;
---
package Conditional_Interfaces is
   type Conditional_Interface is limited interface;

   type Data_Object is tagged null record;

   function Is_Valid
 (This : in Conditional_Interface)
  return Boolean is abstract;

   function Is_Supported_Data
 (This : in Conditional_Interface;
  Data : not null access Data_Object'Class)
  return Boolean is abstract;

   procedure Do_Stuff
 (This : in out Conditional_Interface) is abstract
 with
   Pre'Class => This.Is_Valid;

   procedure Do_Stuff_Access
 (This : not null access Conditional_Interface) is abstract
 with
   Pre'Class => This.Is_Valid;

   procedure Update_Data
 (This : not null access Conditional_Interface;
  Data : not null access Data_Object'Class) is abstract
 with
   Pre'Class => This.Is_Supported_Data (Data)

end Conditional_Interfaces;
---
package body Conditional_Objects is

   procedure Update_Data
 (This : not null access Object;
  Data : not null access Conditional_Interfaces.Data_Object'Class)
   is
   begin
  null;
   end Update_Data;

end Conditional_Objects;
---
with Conditional_Interfaces;

package Conditional_Objects is

   type Object is limited new
 Conditional_Interfaces.Conditional_Interface with null record;

   function Is_Valid
 (This : in Object)
  return Boolean
   is
 (True);

   function Is_Supported_Data
 (This : in Object;
  Data : not null access Conditional_Interfaces.Data_Object'Class)
  return Boolean
   is
 (True);

   procedure Do_Stuff
 (This : in out Object) is null;

   procedure Do_Stuff_Access
 (This : not null access Object) is null;

   procedure Update_Data
 (This : not null access Object;
  Data : not null access Conditional_Interfaces.Data_Object'Class)
-- Doesn't cause errors:
--   with
-- Pre => This.Is_Supported_Data (Data)
   ;
end Conditional_Objects;

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

2017-09-25  Ed Schonberg  

* exp_ch6.adb (Expand_Call_Helper): The extra accessibility check in a
call that appears in a classwide precondition and that mentions an
access formal of the subprogram, must use the accessibility level of
the actual in the call. This is one case in which a reference to a
formal parameter appears outside of the body of the subprogram.

Index: exp_ch6.adb
===
--- exp_ch6.adb (revision 253134)
+++ exp_ch6.adb (working copy)
@@ -3004,6 +3004,20 @@
 then
Prev_Orig := Prev;
 
+--  A class-wide precondition generates a test in which formals of
+--  the subprogram are replaced by actuals that came from source.
+--  In that case as well, the accessiblity comes from the actual.
+--  This is the one case in which there are references to formals
+--  outside of their subprogram.
+
+elsif Prev_Orig /= Prev
+  and then Is_Entity_Name (Prev_Orig)
+  and then Present (Entity (Prev_Orig))
+  and then Is_Formal (Entity (Prev_Orig))
+  and then not In_Open_Scopes (Scope (Entity (Prev_Orig)))
+then
+   Prev_Orig := Prev;
+
 --  If the actual is a formal of an enclosing subprogram it is
 --  the right entity, even if it is a rewriting. This happens
 --  when the call is within an inherited condition or predicate.

[Ada] Insert explicit dereference in GNATprove mode for pointer analysis

[Pierre-Marie de Rodat]

Safe pointer analysis in GNATprove mode depends on explicit dereferences
being present in the tree. Insert them where needed on access to components
in the special expansion performed in GNATprove mode.

The following code is now analysed without errors in GNATprove mode (with
-gnatd.F) with the special debug switch to trigger safe pointer analysis
(with -gnatdF):

 $ gcc -c -gnatd.F -gnatdF ptr.adb

 1. procedure Ptr with SPARK_Mode is
 2.type PInt is access Integer;
 3.type Rec is record
 4.   X, Y : PInt;
 5.end record;
 6.type PRec is access Rec;
 7.type Arr is array (1..10) of PRec;
 8.type PArr is access Arr;
 9.R : PRec := new Rec;
10.A : PArr := new Arr;
11. begin
12.R.X := R.Y;
13.A(1).X := A(2).Y;
14. end Ptr;

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

2017-09-25  Yannick Moy  

* exp_spark.adb (Expand_SPARK_Indexed_Component,
Expand_SPARK_Selected_Component): New procedures to insert explicit
dereference if required.
(Expand_SPARK): Call the new procedures.

Index: exp_spark.adb
===
--- exp_spark.adb   (revision 253141)
+++ exp_spark.adb   (working copy)
@@ -58,6 +58,9 @@
procedure Expand_SPARK_Freeze_Type (E : Entity_Id);
--  Build the DIC procedure of a type when needed, if not already done
 
+   procedure Expand_SPARK_Indexed_Component (N : Node_Id);
+   --  Insert explicit dereference if required
+
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id);
--  Perform object-declaration-specific expansion
 
@@ -67,6 +70,9 @@
procedure Expand_SPARK_Op_Ne (N : Node_Id);
--  Rewrite operator /= based on operator = when defined explicitly
 
+   procedure Expand_SPARK_Selected_Component (N : Node_Id);
+   --  Insert explicit dereference if required
+
--
-- Expand_SPARK --
--
@@ -138,6 +144,12 @@
Expand_SPARK_Freeze_Type (Entity (N));
 end if;
 
+ when N_Indexed_Component =>
+Expand_SPARK_Indexed_Component (N);
+
+ when N_Selected_Component =>
+Expand_SPARK_Selected_Component (N);
+
  --  In SPARK mode, no other constructs require expansion
 
  when others =>
@@ -264,6 +276,20 @@
   end if;
end Expand_SPARK_Freeze_Type;
 
+   
+   -- Expand_SPARK_Indexed_Component --
+   
+
+   procedure Expand_SPARK_Indexed_Component (N : Node_Id) is
+  P   : constant Node_Id:= Prefix (N);
+  T   : constant Entity_Id  := Etype (P);
+   begin
+  if Is_Access_Type (T) then
+ Insert_Explicit_Dereference (P);
+ Analyze_And_Resolve (P, Designated_Type (T));
+  end if;
+   end Expand_SPARK_Indexed_Component;
+
---
-- Expand_SPARK_N_Object_Declaration --
---
@@ -445,4 +471,31 @@
   end if;
end Expand_SPARK_Potential_Renaming;
 
+   -
+   -- Expand_SPARK_Selected_Component --
+   -
+
+   procedure Expand_SPARK_Selected_Component (N : Node_Id) is
+  P: constant Node_Id   := Prefix (N);
+  Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
+   begin
+  if Present (Ptyp)
+and then Is_Access_Type (Ptyp)
+  then
+ --  First set prefix type to proper access type, in case it currently
+ --  has a private (non-access) view of this type.
+
+ Set_Etype (P, Ptyp);
+
+ Insert_Explicit_Dereference (P);
+ Analyze_And_Resolve (P, Designated_Type (Ptyp));
+
+ if Ekind (Etype (P)) = E_Private_Subtype
+   and then Is_For_Access_Subtype (Etype (P))
+ then
+Set_Etype (P, Base_Type (Etype (P)));
+ end if;
+  end if;
+   end Expand_SPARK_Selected_Component;
+
 end Exp_SPARK;

[Ada] Handle errors and limit simultaneous wait objects number in win32_wait

[Pierre-Marie de Rodat]

Everything is in the subject.

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

2017-09-25  Vasiliy Fofanov  

* adaint.c (win32_wait): Properly handle error and take into account
the WIN32 limitation on the number of simultaneous wait objects.

Index: adaint.c
===
--- adaint.c(revision 253141)
+++ adaint.c(working copy)
@@ -2551,6 +2551,7 @@
   DWORD res;
   int hl_len;
   int found;
+  int pos;
 
  START_WAIT:
 
@@ -2563,7 +2564,15 @@
   /*  critical section  */
   EnterCS();
 
+  /* ??? We can't wait for more than MAXIMUM_WAIT_OBJECTS due to a Win32
+ limitation */
+  if (plist_length < MAXIMUM_WAIT_OBJECTS)
   hl_len = plist_length;
+  else
+{
+  errno = EINVAL;
+  return -1;
+}
 
 #ifdef CERT
   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
@@ -2586,6 +2595,13 @@
 
   res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
 
+  /* If there was an error, exit now */
+  if (res == WAIT_FAILED)
+{
+  errno = EINVAL;
+  return -1;
+}
+
   /* if the ProcListEvt has been signaled then the list of processes has been
  updated to add or remove a handle, just loop over */
 
@@ -2596,9 +2612,17 @@
   goto START_WAIT;
 }
 
-  h = hl[res - WAIT_OBJECT_0];
+  /* Handle two distinct groups of return codes: finished waits and abandoned
+ waits */
+
+  if (res < WAIT_ABANDONED_0)
+pos = res - WAIT_OBJECT_0;
+  else
+pos = res - WAIT_ABANDONED_0;
+
+  h = hl[pos];
   GetExitCodeProcess (h, );
-  pid = pidl [res - WAIT_OBJECT_0];
+  pid = pidl [pos];
 
   found = __gnat_win32_remove_handle (h, -1);
 

[Ada] Do not insert calls to invariant procedure in GNATprove mode

[Pierre-Marie de Rodat]

GNATprove handles specially invariant checks, and so does not expect to
see calls to invariant procedures in the AST. This patch fixes the two
places where such calls were inserted during semantic analysis, so that
calls are only inserted when not in GNATprove mode. Possibly the same
could be done in ASIS mode.

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

2017-09-25  Yannick Moy  

* sem_ch3.adb (Constant_Redeclaration): Do not insert a call to the
invariant procedure in GNATprove mode.
* sem_ch5.adb (Analyze_Assignment): Likewise.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 253141)
+++ sem_ch3.adb (working copy)
@@ -12755,9 +12755,13 @@
  end if;
 
  --  A deferred constant is a visible entity. If type has invariants,
- --  verify that the initial value satisfies them.
+ --  verify that the initial value satisfies them. This is not done in
+ --  GNATprove mode, as GNATprove handles invariant checks itself.
 
- if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
+ if Has_Invariants (T)
+   and then Present (Invariant_Procedure (T))
+   and then not GNATprove_Mode
+ then
 Insert_After (N,
   Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N;
  end if;
Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 253141)
+++ sem_ch5.adb (working copy)
@@ -839,14 +839,16 @@
  Set_Referenced_Modified (Lhs, Out_Param => False);
   end if;
 
-  --  RM 7.3.2 (12/3): An assignment to a view conversion (from a type
-  --  to one of its ancestors) requires an invariant check. Apply check
-  --  only if expression comes from source, otherwise it will be applied
-  --  when value is assigned to source entity.
+  --  RM 7.3.2 (12/3): An assignment to a view conversion (from a type to
+  --  one of its ancestors) requires an invariant check. Apply check only
+  --  if expression comes from source, otherwise it will be applied when
+  --  value is assigned to source entity. This is not done in GNATprove
+  --  mode, as GNATprove handles invariant checks itself.
 
   if Nkind (Lhs) = N_Type_Conversion
 and then Has_Invariants (Etype (Expression (Lhs)))
 and then Comes_From_Source (Expression (Lhs))
+and then not GNATprove_Mode
   then
  Insert_After (N, Make_Invariant_Call (Expression (Lhs)));
   end if;

[Ada] Crash on an aspect specification with parameter associations

[Pierre-Marie de Rodat]

This patch fixes a compiler abort in ASIS mode on an aspect specification
whose expression is a function call with parameter associations.

The following must compile quietly:

   gcc -c -gnatct p.adb

---
with System;
procedure P is
 type T is new Integer;

 package Obj is
Buf : T := 1234;
 end Obj;

 function Unchecked_Data_Address (Stream : T;
   Current_Read_Position : Boolean := False) return System.Address;

   function Unchecked_Data_Address (Stream : T;
  Current_Read_Position : Boolean := False) return System.Address is
   begin
return Stream'Address;
   end;

   Result : constant String (1 .. 10)
 with Address =>
   Unchecked_Data_Address (Obj.Buf, Current_Read_Position => True),
 Import, Convention => Ada;

begin
   null;
end; 

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

2017-09-25  Ed Schonberg  

* sem_ch13.adb (Analyze_One_Aspect): In ASIS mode make a full copy of
the expression to be used in the generated attribute specification
(rather than relocating it) to avoid resolving a potentially malformed
tree when the expression is resolved through an ASIS-specific call to
Resolve_Aspect_Expressions.  This manifests itself as a crash on a
function with parameter associations.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 253141)
+++ sem_ch13.adb(working copy)
@@ -2264,13 +2264,29 @@
  end if;
   end if;
 
-  --  Construct the attribute definition clause
+  --  Construct the attribute_definition_clause. The expression
+  --  in the aspect specification is simply shared with the
+  --  constructed attribute, because it will be fully analyzed
+  --  when the attribute is processed. However, in ASIS mode
+  --  the aspect expression itself is preanalyzed and resolved
+  --  to catch visibility errors that are otherwise caught
+  --  later, and we create a separate copy of the expression
+  --  to prevent analysis of a malformed tree (e.g. a function
+  --  call with parameter associations).
 
-  Aitem :=
-Make_Attribute_Definition_Clause (Loc,
-  Name   => Ent,
-  Chars  => Chars (Id),
-  Expression => Relocate_Node (Expr));
+  if ASIS_Mode then
+ Aitem :=
+   Make_Attribute_Definition_Clause (Loc,
+ Name   => Ent,
+ Chars  => Chars (Id),
+ Expression => New_Copy_Tree (Expr));
+  else
+ Aitem :=
+   Make_Attribute_Definition_Clause (Loc,
+ Name   => Ent,
+ Chars  => Chars (Id),
+ Expression => Relocate_Node (Expr));
+  end if;
 
   --  If the address is specified, then we treat the entity as
   --  referenced, to avoid spurious warnings. This is analogous

[Ada] Use the Monotonic Clock on Linux

[Pierre-Marie de Rodat]

The monotonic clock epoch is set to some undetermined time
in the past (typically system boot time).  In order to use the
monotonic clock for absolute time, the offset from a known epoch
is calculated and incorporated into timed delay and sleep.

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

2017-09-25  Doug Rupp  

* libgnarl/s-taprop__linux.adb (Base_Monotonic_Clock): New variable.
(Compute_Base_Monotonic_Clock): New function.
(Timed_Sleep): Adjust to use Base_Monotonic_Clock.
(Timed_Delay): Likewise.
(Monotonic_Clock): Likewise.
* s-oscons-tmplt.c (CLOCK_MONOTONIC): Use on Linux.

Index: s-oscons-tmplt.c
===
--- s-oscons-tmplt.c(revision 253134)
+++ s-oscons-tmplt.c(working copy)
@@ -1440,7 +1440,8 @@
 #endif
 CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock")
 
-#if defined(__FreeBSD__) || (defined(_AIX) && defined(_AIXVERSION_530)) \
+#if defined(__linux__) || defined(__FreeBSD__) \
+ || (defined(_AIX) && defined(_AIXVERSION_530)) \
  || defined(__DragonFly__)
 /** On these platforms use system provided monotonic clock instead of
  ** the default CLOCK_REALTIME. We then need to set up cond var attributes
Index: libgnarl/s-taprop__linux.adb
===
--- libgnarl/s-taprop__linux.adb(revision 253134)
+++ libgnarl/s-taprop__linux.adb(working copy)
@@ -64,6 +64,7 @@
use System.Parameters;
use System.OS_Primitives;
use System.Task_Info;
+   use type Interfaces.C.long;
 

-- Local Data --
@@ -110,6 +111,8 @@
--  Constant to indicate that the thread identifier has not yet been
--  initialized.
 
+   Base_Monotonic_Clock : Duration := 0.0;
+

-- Local Packages --

@@ -160,6 +163,12 @@
 
procedure Abort_Handler (signo : Signal);
 
+   function Compute_Base_Monotonic_Clock return Duration;
+   --  The monotonic clock epoch is set to some undetermined time
+   --  in the past (typically system boot time).  In order to use the
+   --  monotonic clock for absolute time, the offset from a known epoch
+   --  is needed.
+
function GNAT_pthread_condattr_setup
  (attr : access pthread_condattr_t) return C.int;
pragma Import
@@ -257,6 +266,73 @@
   end if;
end Abort_Handler;
 
+   --
+   -- Compute_Base_Monotonic_Clock --
+   --
+
+   function Compute_Base_Monotonic_Clock return Duration is
+  TS_Bef0, TS_Mon0, TS_Aft0 : aliased timespec;
+  TS_Bef,  TS_Mon,  TS_Aft  : aliased timespec;
+  Bef, Mon, Aft : Duration;
+  Res_B, Res_M, Res_A   : Interfaces.C.int;
+   begin
+  Res_B := clock_gettime
+   (clock_id => OSC.CLOCK_REALTIME, tp => TS_Bef0'Unchecked_Access);
+  pragma Assert (Res_B = 0);
+  Res_M := clock_gettime
+   (clock_id => OSC.CLOCK_RT_Ada, tp => TS_Mon0'Unchecked_Access);
+  pragma Assert (Res_M = 0);
+  Res_A := clock_gettime
+   (clock_id => OSC.CLOCK_REALTIME, tp => TS_Aft0'Unchecked_Access);
+  pragma Assert (Res_A = 0);
+
+  for I in 1 .. 10 loop
+ --  Guard against a leap second which will cause CLOCK_REALTIME
+ --  to jump backwards.  In the extrenmely unlikely event we call
+ --  clock_gettime before and after the jump the epoch result will
+ --  be off slightly.
+ --  Use only results where the tv_sec values match for the sake
+ --  of convenience.
+ --  Also try to calculate the most accurate
+ --  epoch by taking the minimum difference of 10 tries.
+
+ Res_B := clock_gettime
+  (clock_id => OSC.CLOCK_REALTIME, tp => TS_Bef'Unchecked_Access);
+ pragma Assert (Res_B = 0);
+ Res_M := clock_gettime
+  (clock_id => OSC.CLOCK_RT_Ada, tp => TS_Mon'Unchecked_Access);
+ pragma Assert (Res_M = 0);
+ Res_A := clock_gettime
+  (clock_id => OSC.CLOCK_REALTIME, tp => TS_Aft'Unchecked_Access);
+ pragma Assert (Res_A = 0);
+
+ if (TS_Bef0.tv_sec /= TS_Aft0.tv_sec and then
+ TS_Bef.tv_sec  = TS_Aft.tv_sec)
+--  The calls to clock_gettime before the loop were no good.
+or else
+(TS_Bef0.tv_sec = TS_Aft0.tv_sec and then
+ TS_Bef.tv_sec  = TS_Aft.tv_sec and then
+(TS_Aft.tv_nsec  - TS_Bef.tv_nsec <
+ TS_Aft0.tv_nsec - TS_Bef0.tv_nsec))
+--  The most recent calls to clock_gettime were more better.
+ then
+TS_Bef0.tv_sec := TS_Bef.tv_sec;
+TS_Bef0.tv_nsec := TS_Bef.tv_nsec;
+TS_Aft0.tv_sec := TS_Aft.tv_sec;
+TS_Aft0.tv_nsec := TS_Aft.tv_nsec;
+TS_Mon0.tv_sec := TS_Mon.tv_sec;
+TS_Mon0.tv_nsec := TS_Mon.tv_nsec;
+ end if;
+  end 

[Ada] Improve performance of 'Image with enumeration types.

[Pierre-Marie de Rodat]

This patch improves the performance of the code generated by the compiler
for attribute Image when applied to user-defined enumeration types and the
sources are compiled with optimizations enabled.

No test required.

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

2017-09-25  Javier Miranda  

* exp_imgv.adb (Is_User_Defined_Enumeration_Type): New subprogram.
(Expand_User_Defined_Enumeration_Image): New subprogram.
(Expand_Image_Attribute): Enable speed-optimized expansion of
user-defined enumeration types when we are compiling with optimizations
enabled.

Index: exp_imgv.adb
===
--- exp_imgv.adb(revision 253134)
+++ exp_imgv.adb(working copy)
@@ -263,10 +263,176 @@
--  position of the enumeration value in the enumeration type.
 
procedure Expand_Image_Attribute (N : Node_Id) is
-  Loc   : constant Source_Ptr := Sloc (N);
-  Exprs : constant List_Id:= Expressions (N);
-  Pref  : constant Node_Id:= Prefix (N);
-  Expr  : constant Node_Id:= Relocate_Node (First (Exprs));
+  Loc   : constant Source_Ptr := Sloc (N);
+  Exprs : constant List_Id:= Expressions (N);
+  Expr  : constant Node_Id:= Relocate_Node (First (Exprs));
+  Pref  : constant Node_Id:= Prefix (N);
+
+  function Is_User_Defined_Enumeration_Type
+(Typ : Entity_Id) return Boolean;
+  --  Return True if Typ is an user-defined enumeration type
+
+  procedure Expand_User_Defined_Enumeration_Image;
+  --  Expand attribute 'Image in user-defined enumeration types avoiding
+  --  string copy.
+
+  ---
+  -- Expand_User_Defined_Enumeration_Image --
+  ---
+
+  procedure Expand_User_Defined_Enumeration_Image is
+ Ins_List : constant List_Id   := New_List;
+ P1_Id: constant Entity_Id := Make_Temporary (Loc, 'P');
+ P2_Id: constant Entity_Id := Make_Temporary (Loc, 'P');
+ P3_Id: constant Entity_Id := Make_Temporary (Loc, 'P');
+ P4_Id: constant Entity_Id := Make_Temporary (Loc, 'P');
+ Ptyp : constant Entity_Id := Entity (Pref);
+ Rtyp : constant Entity_Id := Root_Type (Ptyp);
+ S1_Id: constant Entity_Id := Make_Temporary (Loc, 'S');
+
+  begin
+ --  Apply a validity check, since it is a bit drastic to get a
+ --  completely junk image value for an invalid value.
+
+ if not Expr_Known_Valid (Expr) then
+Insert_Valid_Check (Expr);
+ end if;
+
+ --  Generate:
+ --P1 : constant Natural := Pos;
+
+ Append_To (Ins_List,
+   Make_Object_Declaration (Loc,
+ Defining_Identifier => P1_Id,
+ Object_Definition   =>
+   New_Occurrence_Of (Standard_Natural, Loc),
+ Constant_Present=> True,
+ Expression =>
+   Convert_To (Standard_Natural,
+ Make_Attribute_Reference (Loc,
+   Attribute_Name => Name_Pos,
+   Prefix => New_Occurrence_Of (Ptyp, Loc),
+   Expressions=> New_List (Expr);
+
+ --  Compute the index of the string start generating:
+ --P2 : constant Natural := call_put_enumN (P1);
+
+ Append_To (Ins_List,
+   Make_Object_Declaration (Loc,
+ Defining_Identifier => P2_Id,
+ Object_Definition   =>
+   New_Occurrence_Of (Standard_Natural, Loc),
+ Constant_Present=> True,
+ Expression =>
+   Convert_To (Standard_Natural,
+ Make_Indexed_Component (Loc,
+   Prefix  =>
+ New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
+   Expressions =>
+ New_List (New_Occurrence_Of (P1_Id, Loc));
+
+ --  Compute the index of the next value generating:
+ --P3 : constant Natural := call_put_enumN (P1 + 1);
+
+ declare
+Add_Node : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
+
+ begin
+Set_Left_Opnd  (Add_Node, New_Occurrence_Of (P1_Id, Loc));
+Set_Right_Opnd (Add_Node, Make_Integer_Literal (Loc, 1));
+
+Append_To (Ins_List,
+  Make_Object_Declaration (Loc,
+Defining_Identifier => P3_Id,
+Object_Definition   =>
+  New_Occurrence_Of (Standard_Natural, Loc),
+Constant_Present=> True,
+Expression =>
+  Convert_To (Standard_Natural,
+Make_Indexed_Component (Loc,
+  Prefix  =>
+New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
+  Expressions =>
+  

[Ada] Remove duplicated Has_Null_Abstract_State routines

[Pierre-Marie de Rodat]

Cleanup only; semantics unaffected.

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

2017-09-25  Piotr Trojanek  

* sem_util.adb (Has_Null_Abstract_State): Remove, as an exactly same
routine is already provided by Einfo.
* einfo.adb (Has_Null_Abstract_State): Replace with the body from
Sem_Util, which had better comments and avoided double calls to
Abstract_State.

Index: einfo.adb
===
--- einfo.adb   (revision 253134)
+++ einfo.adb   (working copy)
@@ -7707,12 +7707,17 @@
-
 
function Has_Null_Abstract_State (Id : E) return B is
-   begin
   pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
 
+  States : constant Elist_Id := Abstract_States (Id);
+
+   begin
+  --  Check first available state of related package. A null abstract
+  --  state always appears as the sole element of the state list.
+
   return
-Present (Abstract_States (Id))
-  and then Is_Null_State (Node (First_Elmt (Abstract_States (Id;
+Present (States)
+  and then Is_Null_State (Node (First_Elmt (States)));
end Has_Null_Abstract_State;
 
-
Index: sem_util.adb
===
--- sem_util.adb(revision 253134)
+++ sem_util.adb(working copy)
@@ -3138,34 +3138,10 @@
---
 
procedure Check_No_Hidden_State (Id : Entity_Id) is
-  function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
-  --  Determine whether the entity of a package denoted by Pkg has a null
-  --  abstract state.
-
-  -
-  -- Has_Null_Abstract_State --
-  -
-
-  function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
- States : constant Elist_Id := Abstract_States (Pkg);
-
-  begin
- --  Check first available state of related package. A null abstract
- --  state always appears as the sole element of the state list.
-
- return
-   Present (States)
- and then Is_Null_State (Node (First_Elmt (States)));
-  end Has_Null_Abstract_State;
-
-  --  Local variables
-
   Context : Entity_Id := Empty;
   Not_Visible : Boolean   := False;
   Scop: Entity_Id;
 
-   --  Start of processing for Check_No_Hidden_State
-
begin
   pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
 

[Ada] Entry family selector not recognised as entity usage

[Pierre-Marie de Rodat]

This patch corrects an issue whereby index actuals in calls to entry families
were not being properly flagged as referenced leading to spurious warnings
when compiling with -gnatwu.

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

gcc/ada/

2017-09-25  Justin Squirek  

* sem_res.adb (Resolve_Entry): Generate reference for index entities.

gcc/testsuite/

2017-09-25  Justin Squirek  

* gnat.dg/entry_family.adb: New testcase

Index: sem_res.adb
===
--- sem_res.adb (revision 253134)
+++ sem_res.adb (working copy)
@@ -7474,6 +7474,15 @@
  Index := First (Expressions (Entry_Name));
  Resolve (Index, Entry_Index_Type (Nam));
 
+ --  Generate a reference for the index entity when the index is not a
+ --  literal.
+
+ if Nkind (Index) in N_Has_Entity
+   and then Nkind (Entity (Index)) in N_Entity
+ then
+Generate_Reference (Entity (Index), Nam, ' ');
+ end if;
+
  --  Up to this point the expression could have been the actual in a
  --  simple entry call, and be given by a named association.
 
Index: ../testsuite/gnat.dg/entry_family.adb
===
--- ../testsuite/gnat.dg/entry_family.adb   (revision 0)
+++ ../testsuite/gnat.dg/entry_family.adb   (revision 0)
@@ -0,0 +1,28 @@
+--  { dg-do compile }
+--  { dg-options "-gnatwu" }
+
+with Ada.Numerics.Discrete_Random; use Ada.Numerics;
+
+procedure Entry_Family is
+   protected Family is
+  entry Call (Boolean);
+   end Family;
+
+   protected body Family is
+  entry Call (for P in Boolean) when True is
+  begin
+ null;
+  end Call;
+
+   end Family;
+
+   package Random_Boolean is new Discrete_Random (Result_Subtype => Boolean);
+   use Random_Boolean;
+
+   Boolean_Generator : Generator;
+
+   B : constant Boolean := Random (Boolean_Generator);
+
+begin
+   Family.Call (B);
+end Entry_Family;

[Ada] Spurious visibility error in ASIS mode

[Pierre-Marie de Rodat]

In ASIS mode we resolve the expressions in aspect specifications to provide
sufficient semantic information, including entities and types of identifiers.
The tree traversal that performs this resolution must omit identifiers that
are selector names of parameter associations in calls, because these do not
carry entity information.

The following must compile quietly:

   gcc -c -gnatct check.adb

   package Check is
  function String_OK (Name : String) return Boolean;
  type  S1 is new String with Dynamic_Predicate =>
String_OK (Name => String (S1));
   end Check;
---
   package body Check is
  function String_OK (Name : String) return Boolean is
  begin
 return True;
  end;
   end Check;

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

2017-09-25  Ed Schonberg  

* sem_ch13.adb (Resolve_Aspect_Expressions): Do not resolve identifiers
that appear as selector names of parameter associations, as these are
never resolved by visibility.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 253135)
+++ sem_ch13.adb(working copy)
@@ -12797,7 +12797,14 @@
 
 return Skip;
 
- elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then
+ --  Resolve identifiers that are not selectors in parameter
+ --  associations (these are never resolved by visibility).
+
+ elsif Nkind (N) = N_Identifier
+   and then Chars (N) /= Chars (E)
+   and then (Nkind (Parent (N)) /= N_Parameter_Association
+  or else N /= Selector_Name (Parent (N)))
+ then
 Find_Direct_Name (N);
 
 --  In ASIS mode we must analyze overloaded identifiers to ensure

[Ada] Proper qualification of concurrent discriminants

[Pierre-Marie de Rodat]

This patch modifies resolution to perform minor expansion for SPARK in order to
properly qualify concurrent discriminants used as defaulted actuals in calls.


-- Source --


--  p.ads

package P is
   protected type PT (D : Integer) is
  procedure Dummy (Arg : Integer := D);
   end;

   PO : PT (0);
end P;

--  main.adb

with P;

procedure Main is
begin
   P.PO.Dummy;
end Main;


-- Compilation and output --


$ gcc -c -gnatdg -gnatd.F main.adb
with p;
with system;

procedure main is
begin
   p.po.dummy (arg => p.po.d);
end main;

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

2017-09-25  Hristian Kirtchev  

* sem_res.adb (Replace_Actual_Discriminants): Replace a discriminant
for GNATprove.
(Resolve_Entry): Clean up predicate

Index: sem_res.adb
===
--- sem_res.adb (revision 253139)
+++ sem_res.adb (working copy)
@@ -1837,7 +1837,17 @@
--  Start of processing for Replace_Actual_Discriminants
 
begin
-  if not Expander_Active then
+  if Expander_Active then
+ null;
+
+  --  Allow the replacement of concurrent discriminants in GNATprove even
+  --  though this is a light expansion activity. Note that generic units
+  --  are not modified.
+
+  elsif GNATprove_Mode and not Inside_A_Generic then
+ null;
+
+  else
  return;
   end if;
 
@@ -1848,9 +1858,7 @@
  Tsk := Prefix (Prefix (Name (N)));
   end if;
 
-  if No (Tsk) then
- return;
-  else
+  if Present (Tsk) then
  Replace_Discrs (Default);
   end if;
end Replace_Actual_Discriminants;
@@ -3561,6 +3569,7 @@
 Rewrite (Actval,
   Make_Raise_Constraint_Error (Loc,
 Reason => CE_Range_Check_Failed));
+
 Set_Raises_Constraint_Error (Actval);
 Set_Etype (Actval, Etype (F));
  end if;
@@ -3568,12 +3577,12 @@
  Assoc :=
Make_Parameter_Association (Loc,
  Explicit_Actual_Parameter => Actval,
- Selector_Name => Make_Identifier (Loc, Chars (F)));
+ Selector_Name => Make_Identifier (Loc, Chars (F)));
 
  --  Case of insertion is first named actual
 
- if No (Prev) or else
-Nkind (Parent (Prev)) /= N_Parameter_Association
+ if No (Prev)
+   or else Nkind (Parent (Prev)) /= N_Parameter_Association
  then
 Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
 Set_First_Named_Actual (N, Actval);
@@ -7474,13 +7483,10 @@
  Index := First (Expressions (Entry_Name));
  Resolve (Index, Entry_Index_Type (Nam));
 
- --  Generate a reference for the index entity when the index is not a
- --  literal.
+ --  Generate a reference for the index when it denotes an entity
 
- if Nkind (Index) in N_Has_Entity
-   and then Nkind (Entity (Index)) in N_Entity
- then
-Generate_Reference (Entity (Index), Nam, ' ');
+ if Is_Entity_Name (Index) then
+Generate_Reference (Entity (Index), Nam);
  end if;
 
  --  Up to this point the expression could have been the actual in a

[Ada] Minor clean up of contract freezing

[Pierre-Marie de Rodat]

This patch updates the analysis of Refined_State triggered by contract freezing
to raise a more suitable exception when compilation has to be halted.


-- Source --


--  pack.ads

package Pack
  with Abstract_State => State
is
   function F return Boolean with Global => State;

   generic
   package Gen_Pack
 with Abstract_State=> Gen_State,
  Initial_Condition => F
   is
  procedure Proc (X : in out Integer);
   end Gen_Pack;

private
   A : Integer with Part_Of => State;
end Pack;

--  pack.adb

package body Pack
  with Refined_State => (State => (A, B, Inst_Pack.Gen_State))
is
   B : Integer := 6;

   function F return Boolean is (B > 0);

   package body Gen_Pack
 with Refined_State => (Gen_State => C)
   is
  C : Integer;

  procedure Proc (X : in out Integer) is
  begin
if C = X and A = X then
   X := C;
end if;
  end Proc;
   begin
  Proc (C);
   end Gen_Pack;

   package Inst_Pack is new Gen_Pack;

begin
   Inst_Pack.Proc (B);
end Pack;


-- Compilation and output --


$ gcc -c pack.adb
pack.adb:2:08: body "F" declared at line 6 freezes the contract of "Pack"
pack.adb:2:08: all constituents must be declared before body at line 6
pack.adb:2:42: "Inst_Pack" is undefined
compilation abandoned

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

2017-09-25  Hristian Kirtchev  

* sem_prag.adb (Analyze_Constituent): Raise Unrecoverable_Error rather
than Program_Error because U_E is more in line with respect to the
intended behavior.

Index: sem_prag.adb
===
--- sem_prag.adb(revision 253134)
+++ sem_prag.adb(working copy)
@@ -13219,7 +13219,7 @@
  Analyze (N);
  raise Pragma_Exit;
 
- --  No other possibilities
+  --  No other possibilities
 
   when others =>
  raise Program_Error;
@@ -27448,7 +27448,7 @@
 --  Stop the compilation, as this leads to a multitude
 --  of misleading cascaded errors.
 
-raise Program_Error;
+raise Unrecoverable_Error;
  end if;
 
   --  The constituent is a valid state or object

[Ada] Crash on instantiation with renamed formal package.

[Pierre-Marie de Rodat]

This patch fixes a compiler abort on a package instantiation when the
corresponding generic has a formal package, and the instantiation has an
actual that renames the desired package instance.

The following must compile quietly:

   gcc -c mc.adb

---
package MC is
  procedure Dump_States;
end MC;
---
with Configurations;
with UCTL;
package body MC is
  package MyConfigurations is new Configurations;
  package Configurations renames MyConfigurations;

  package MyUCTL0 is new UCTL(MYConfigurations);
  package MyUCTL is new UCTL(Configurations);

  procedure Dump_States is
  begin
MyUCTL.Doit;
  end Dump_States;
begin
  null;
end MC;
---
generic
package Configurations is
 procedure Doit;
end Configurations;
---
package body Configurations is
 procedure Doit is begin null; end;
begin
  null;
end Configurations;
---
with Configurations;
generic
with package MyConfigurations is new Configurations(<>);
package UCTL is
  procedure Doit;
end UCTL;
---
package body UCTL is
 procedure Doit is
 begin
   MyConfigurations.Doit;
 end;
end;

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

2017-09-25  Ed Schonberg  

* sem_ch12.adb (Analyze_Associations, case N_Formal_Package): If the
actual is a renaming, indicate that it is the renamed package that must
be frozen before the instantiation.

Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 253135)
+++ sem_ch12.adb(working copy)
@@ -1980,8 +1980,22 @@
 
if Needs_Freezing then
   Check_Generic_Parent;
-  Set_Has_Delayed_Freeze (Actual);
-  Append_Elmt (Actual, Actuals_To_Freeze);
+
+  --  If the actual is a renaming of a proper
+  --  instance of the formal package, indicate
+  --  that it is the instance that must be frozen.
+
+  if Nkind (Parent (Actual)) =
+N_Package_Renaming_Declaration
+  then
+ Set_Has_Delayed_Freeze
+   (Renamed_Entity (Actual));
+ Append_Elmt
+  (Renamed_Entity (Actual), Actuals_To_Freeze);
+  else
+ Set_Has_Delayed_Freeze (Actual);
+ Append_Elmt (Actual, Actuals_To_Freeze);
+  end if;
end if;
 end if;
  end Explicit_Freeze_Check;

[Ada] Use of renamings in pragmas

[Pierre-Marie de Rodat]

This patch suppresses the transformation of references to renamings into
references to renamed names when the reference appears within a pragma of
no significance to SPARK.


-- Source --


--  uname.adb

procedure Uname is
   type Bounded_String is record
  Length : Natural;
   end record;

   Global_Name_Buffer : Bounded_String := (Length => 0);
   Right_Length   : Natural renames Global_Name_Buffer.Length;

begin
   pragma Warnings (Off, Right_Length);
   pragma Assert (Right_Length = 0);
end Uname;


-- Compilation and output --


$ gcc -c -gnatdg -gnatd.F uname.adb
with system;

procedure uname is
   type bounded_string is record
  length : natural;
   end record;
   freeze bounded_string []
   global_name_buffer : bounded_string := (
  length => 0);
   right_length : natural renames global_name_buffer.length;
begin
   pragma warnings (off, right_length);
   pragma check (assert, global_name_buffer.length = 0);
   null;
end uname;

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

2017-09-25  Hristian Kirtchev  

* exp_spark.adb (Expand_SPARK_Potential_Renaming): Do not process a
reference when it appears within a pragma of no significance to SPARK.
(In_Insignificant_Pragma): New routine.
* sem_prag.ads: Add new table Pragma_Significant_In_SPARK.

Index: sem_prag.ads
===
--- sem_prag.ads(revision 253134)
+++ sem_prag.ads(working copy)
@@ -175,6 +175,25 @@
   Pragma_Warnings=> True,
   others => False);
 
+   --  The following table lists all pragmas which are significant in SPARK and
+   --  as a result get translated into verification conditions. The table is an
+   --  amalgamation of the pragmas listed in SPARK RM 16.1 and internally added
+   --  entries.
+
+   Pragma_Significant_In_SPARK : constant array (Pragma_Id) of Boolean :=
+ (Pragma_All_Calls_Remote  => False,
+  Pragma_Asynchronous  => False,
+  Pragma_Default_Storage_Pool  => False,
+  Pragma_Discard_Names => False,
+  Pragma_Dispatching_Domain=> False,
+  Pragma_Priority_Specific_Dispatching => False,
+  Pragma_Remote_Call_Interface => False,
+  Pragma_Remote_Types  => False,
+  Pragma_Shared_Passive=> False,
+  Pragma_Task_Dispatching_Policy   => False,
+  Pragma_Warnings  => False,
+  others   => True);
+
-
-- Subprograms --
-
Index: exp_spark.adb
===
--- exp_spark.adb   (revision 253134)
+++ exp_spark.adb   (working copy)
@@ -36,6 +36,7 @@
 with Rtsfind;  use Rtsfind;
 with Sem;  use Sem;
 with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sinfo;use Sinfo;
@@ -368,11 +369,46 @@
-
 
procedure Expand_SPARK_Potential_Renaming (N : Node_Id) is
+  function In_Insignificant_Pragma (Nod : Node_Id) return Boolean;
+  --  Determine whether arbitrary node Nod appears within a significant
+  --  pragma for SPARK.
+
+  -
+  -- In_Insignificant_Pragma --
+  -
+
+  function In_Insignificant_Pragma (Nod : Node_Id) return Boolean is
+ Par : Node_Id;
+
+  begin
+ --  Climb the parent chain looking for an enclosing pragma
+
+ Par := Nod;
+ while Present (Par) loop
+if Nkind (Par) = N_Pragma then
+   return not Pragma_Significant_In_SPARK (Get_Pragma_Id (Par));
+
+--  Prevent the search from going too far
+
+elsif Is_Body_Or_Package_Declaration (Par) then
+   exit;
+end if;
+
+Par := Parent (Par);
+ end loop;
+
+ return False;
+  end In_Insignificant_Pragma;
+
+  --  Local variables
+
   Loc: constant Source_Ptr := Sloc (N);
   Obj_Id : constant Entity_Id  := Entity (N);
   Typ: constant Entity_Id  := Etype (N);
   Ren: Node_Id;
 
+   --  Start of processing for Expand_SPARK_Potential_Renaming
+
begin
   --  Replace a reference to a renaming with the actual renamed object
 
@@ -381,12 +417,20 @@
 
  if Present (Ren) then
 
+--  Do not process a reference when it appears within a pragma of
+--  no significance to SPARK. It is assumed that the replacement
+--  will violate the semantics of the pragma and cause a spurious
+--  error.
+
+if In_Insignificant_Pragma (N) then
+   return;
+
 --  Instantiations and 

[Ada] Default to no source locations in non-GCC backend bug boxes

[Pierre-Marie de Rodat]

Default to "No source file position information available" message for
bug boxes emitted from the non-GCC backends. No test provided, because
this only affects bug boxes.

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

2017-09-25  Piotr Trojanek  

* adabkend.adb (Call_Back_End): Reset Current_Error_Node when starting
the backend.

Index: adabkend.adb
===
--- adabkend.adb(revision 253134)
+++ adabkend.adb(working copy)
@@ -6,7 +6,7 @@
 --  --
 -- B o d y  --
 --  --
--- Copyright (C) 2001-2016, AdaCore --
+-- Copyright (C) 2001-2017, AdaCore --
 --  --
 -- 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- --
@@ -22,6 +22,7 @@
 
 --  This is the version of the Back_End package for back ends written in Ada
 
+with Atree;use Atree;
 with Debug;
 with Lib;
 with Opt;  use Opt;
@@ -56,6 +57,13 @@
  Write_Eol;
   end if;
 
+  --  Frontend leaves the Current_Error_Node at a location that is
+  --  meaningless and confusing when emitting bugboxes from the backed. By
+  --  resetting it here we default to "No source file position information
+  --  available" message on backend crashes.
+
+  Current_Error_Node := Empty;
+
   Driver (Lib.Cunit (Types.Main_Unit));
end Call_Back_End;
 

Re: [PATCH] [PR82155] Fix crash in dwarf2out_abstract_function

[Pierre-Marie de Rodat]

On 09/25/2017 01:54 PM, Richard Biener wrote:

Ok for trunk and gcc-7 branch after a while.


Thank you, Richard! Committed on trunk as 253147; I’ll wait at least one 
week to revisit the gcc-7 branch commit.


--
Pierre-Marie de Rodat

Re: [PATCH] [PR79542][Ada] Fix ICE in dwarf2out.c with nested func. inlining

[Pierre-Marie de Rodat]

On 08/18/2017 12:10 PM, Richard Biener wrote:

ok, not doing this at all doesn't work, doing it only in the above case neither.

Bah.

Can anyone explain to me why we do the set_decl_origin_self dance?


Ok, so I need the following incremental patch to fix the fallout.

This allows Ada LTO bootstrap to succeed with the early LTO debug patches.

I assume this change is ok ontop of the LTO debug patches unless I
hear otherwise
til Monday (when I then finally will commit the series).

Full bootstrap/testing running now.
Sorry for the late answer, I’ve been busy the last two weeks. As 
discussed on IRC, I’m not very familiar with debug info generation for 
optimized code yet anyway. ;-)


Are there still pending issues with this? Also, do you think we can port 
the fix for PR79542 on the 7 release branch?


--
Pierre-Marie de Rodat

Re: [PATCH v2] Python testcases to check DWARF output

[Pierre-Marie de Rodat]

Hello,

I would like to ping for the patch I submitted at 
<https://gcc.gnu.org/ml/gcc-patches/2017-08/msg00653.html>. Thank you in 
advance!

--
Pierre-Marie de Rodat

Re: [PATCH] [PR79542][Ada] Fix ICE in dwarf2out.c with nested func. inlining

[Pierre-Marie de Rodat]

On 09/04/2017 11:26 AM, Richard Biener wrote:

No more pending issues and yes, I guess the fix is ok for the branch.


Ok, thanks! This is now comitted on the 7 release branch.

--
Pierre-Marie de Rodat

[Ada] Static allocation of secondary dispatch tables

[Pierre-Marie de Rodat]

This patch enhances the compiler to statically allocate secondary
dispatch tables.

No test available because it would require the analysis of the
generated assembly code (thus depending on the target architecture).

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

2017-10-09  Javier Miranda  

* exp_ch3.adb (Expand_N_Object_Declaration): Avoid never-ending loop
processing the declaration of the dummy object internally created by
Make_DT to compute the offset to the top of components referencing
secondary dispatch tables.
(Initialize_Tag): Do not initialize the offset-to-top field if it has
been initialized initialized.
* exp_disp.ads (Building_Static_Secondary_DT): New subprogram.
* exp_disp.adb (Building_Static_Secondary_DT): New subprogram.
(Make_DT): Create a dummy constant object if we can statically build
secondary dispatch tables.
(Make_Secondary_DT): For statically allocated secondary dispatch tables
use the dummy object to compute the offset-to-top field value by means
of the attribute 'Position.

Index: exp_ch3.adb
===
--- exp_ch3.adb (revision 253548)
+++ exp_ch3.adb (working copy)
@@ -6138,6 +6138,19 @@
  return;
   end if;
 
+  --  No action needed for the internal imported dummy object added by
+  --  Make_DT to compute the offset of the components that reference
+  --  secondary dispatch tables; required to avoid never-ending loop
+  --  processing this internal object declaration.
+
+  if Tagged_Type_Expansion
+and then Is_Internal (Def_Id)
+and then Is_Imported (Def_Id)
+and then Related_Type (Def_Id) = Implementation_Base_Type (Typ)
+  then
+ return;
+  end if;
+
   --  First we do special processing for objects of a tagged type where
   --  this is the point at which the type is frozen. The creation of the
   --  dispatch table and the initialization procedure have to be deferred
@@ -8384,10 +8397,13 @@
  --  Normal case: No discriminants in the parent type
 
  else
---  Don't need to set any value if this interface shares the
---  primary dispatch table.
+--  Don't need to set any value if the offset-to-top field is
+--  statically set or if this interface shares the primary
+--  dispatch table.
 
-if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
+if not Building_Static_Secondary_DT (Typ)
+  and then not Is_Ancestor (Iface, Typ, Use_Full_View => True)
+then
Append_To (Stmts_List,
  Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag=> New_Occurrence_Of (Iface_Tag, Loc),
Index: exp_disp.adb
===
--- exp_disp.adb(revision 253546)
+++ exp_disp.adb(working copy)
@@ -29,6 +29,7 @@
 with Einfo;use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Expander; use Expander;
 with Exp_Atag; use Exp_Atag;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_CG;   use Exp_CG;
@@ -300,6 +301,32 @@
end Building_Static_DT;
 
--
+   -- Building_Static_Secondary_DT --
+   --
+
+   function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
+  Full_Typ : Entity_Id := Typ;
+  Root_Typ : Entity_Id := Root_Type (Typ);
+
+   begin
+  --  Handle private types
+
+  if Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+  end if;
+
+  if Present (Full_View (Root_Typ)) then
+ Root_Typ := Full_View (Root_Typ);
+  end if;
+
+  return Building_Static_DT (Full_Typ)
+and then not Is_Interface (Full_Typ)
+and then Has_Interfaces (Full_Typ)
+and then (Full_Typ = Root_Typ
+or else not Is_Variable_Size_Record (Etype (Full_Typ)));
+   end Building_Static_Secondary_DT;
+
+   --
-- Build_Static_Dispatch_Tables --
--
 
@@ -1693,11 +1720,10 @@
 
if From_Limited_With (Actual_Typ) then
 
-  --  If the type of the actual parameter comes from a
-  --  limited with-clause and the non-limited view is already
-  --  available, we replace the anonymous access type by
-  --  a duplicate declaration whose designated type is the
-  --  non-limited view.
+  --  If the type of the actual parameter comes from a limited
+  --  with_clause and the nonlimited view is already available,
+  --  we replace the anonymous access type by a duplicate
+  --  declaration whose designated type is the 

[Ada] Spurious error with expression function returning anonymous access

[Pierre-Marie de Rodat]

This patch fixes a spurious error on an expression function that is a
completion, when the expression is a function call that returns an anonymous
access type. The preanalysis of the expression to freeze referenced types
requires the proper computation of the access level of the function call,
at a point where the expression is not yet part of the generated tree for
the body that represents the completion.

The following must compile quietly:

 gcc -c print_interval_quotes.adb

--
with Data_Serializer.Quote_Data;
procedure Print_Interval_Quotes is
begin
   null;
end Print_Interval_Quotes;
---
package Data_Serializer.Futures_Support is

   type Futures_Loader_Kind_Type is (Disabled, Default, Explicit);

   type Futures_Loader_Param_Type
   (Kind : Futures_Loader_Kind_Type := Disabled)
 is record
case Kind is
   when Disabled | Default => null;
   when Explicit =>
  Rollover_Offset : Duration;
  Matching_Offset : Duration;
end case;
 end record;

end Data_Serializer.Futures_Support;
--
package body Data_Serializer.Generic_Per_Day_Data is

   function Default_Element (DS : Data_Source_Type) return Element_Type'Class
   is
   begin
  return Data_Wrapper_Type'((X => Null_D'Access));
   end Default_Element;

   function Next_Pointer (DS : Data_Source_Type)
 return not null access constant Data_Type
   is begin
  return Null_D'Access;
   end Next_Pointer;

   function Next (DS : in out Data_Source_Type) return Element_Type'Class is
  (Data_Wrapper_Type'(X => Next_Pointer (DS)));

   function First (DS : Data_Source_Type) return Cursor_Type
 --  Setting "is (null)" removes the bug
 --  is (null);
 is
   --  begin return
(Next_Pointer (DS));
 --  end;

end Data_Serializer.Generic_Per_Day_Data;
---
generic
   type Data_Type is private;
   Null_Data : Data_Type;
package Data_Serializer.Generic_Per_Day_data is

   Null_D : aliased constant Data_Type := Null_Data;
   type Data_Type_T_Array_Access is access Integer;

   type Data_Wrapper_Type
 (X : not null access constant Data_Type)
 is new Element_Type with null record
 with Implicit_Dereference => X;
   overriding function Timestamp (D : Data_Wrapper_Type) return Time is (0);

   type Data_Source_Type is limited new Source_Type with private;

   type Cursor_Type (<>) is private;

   function First (DS : Data_Source_Type) return Cursor_Type;

private
   type Data_Source_Type_Access is not null access all Data_Source_Type;

   type Writable_Access
 (Self : not null access Data_Source_Type)
 is limited null record;

   type Data_Source_Type
 is limited new Source_Type with null record;

   type Cursor_Type is access constant Data_Type;

end Data_Serializer.Generic_Per_Day_Data;
---
with Data_Serializer.Generic_Per_Day_Data;
with Quotes;

package Data_Serializer.Quote_Data is new Data_Serializer.Generic_Per_Day_Data
  (Data_Type  => Quotes.Quote_Type,
   Null_Data  => Quotes.Null_Quote
   );
package Data_Serializer is
   type Time is new Integer;

   type Element_Type is interface;
   function Timestamp (E : Element_Type) return Time is abstract;

   type Source_Type is abstract tagged limited null record;

end Data_Serializer;
--
package Quotes is
   type Quote_Type is new Integer;
   Null_Quote : constant Quote_Type := 0;
end Quotes;

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

2017-10-09  Ed Schonberg  

* sem_util.adb (Object_Access_Level): If the object is the return
statement of an expression function, return the level of the function.
This is relevant when the object involves an implicit conversion
between access types and the expression function is a completion, which
forces the analysis of the expression before rewriting it as a body, so
that freeze nodes can appear in the proper scope.

Index: sem_util.adb
===
--- sem_util.adb(revision 253548)
+++ sem_util.adb(working copy)
@@ -20383,6 +20383,17 @@
 (Nearest_Dynamic_Scope
(Defining_Entity (Node_Par)));
 
+--  For a return statement within a function, return
+--  the depth of the function itself. This is not just
+--  a small optimization, but matters when analyzing
+--  the expression in an expression function before
+--  the body is created.
+
+when N_Simple_Return_Statement =>
+   if Ekind (Current_Scope) = E_Function then
+  return Scope_Depth (Current_Scope);
+   end if;
+
 when others =>
null;
  end case;

[Ada] Improve nnd debugging hooks

[Pierre-Marie de Rodat]

This patch improves and simplifies the debugging hooks.  Now you just have to
break on nnd to find all "interesting" creations/modifications of node ids.  No
change in functionality; no test available.

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

2017-10-09  Bob Duff  

* atree.adb: Make nnd apply to everything "interesting", including
Rewrite.  Remove rrd.

Index: atree.adb
===
--- atree.adb   (revision 253546)
+++ atree.adb   (working copy)
@@ -73,12 +73,13 @@
-- ww := 12345
--  and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue.
 
-   --  Either way, gnat1 will stop when node 12345 is created
+   --  Either way, gnat1 will stop when node 12345 is created, or certain other
+   --  interesting operations are performed, such as Rewrite. To see exactly
+   --  which operations, search for "pragma Debug" below.
 
-   --  The second method is much faster
+   --  The second method is much faster if the amount of Ada code being
+   --  compiled is large.
 
-   --  Similarly, rr and rrd allow breaking on rewriting of a given node
-
ww : Node_Id'Base := Node_Id'First - 1;
pragma Export (Ada, ww); --  trick the optimizer
Watch_Node : Node_Id'Base renames ww;
@@ -103,24 +104,8 @@
--  If Node = Watch_Node, this prints out the new node and calls
--  New_Node_Breakpoint. Otherwise, does nothing.
 
-   procedure rr;
-   pragma Export (Ada, rr);
-   procedure Rewrite_Breakpoint renames rr;
-   --  This doesn't do anything interesting; it's just for setting breakpoint
-   --  on as explained above.
-
-   procedure rrd (Old_Node, New_Node : Node_Id);
-   pragma Export (Ada, rrd);
-   procedure Rewrite_Debugging_Output
- (Old_Node, New_Node : Node_Id) renames rrd;
-   --  For debugging. If debugging is turned on, Rewrite calls this. If debug
-   --  flag N is turned on, this prints out the new node.
-   --
-   --  If Old_Node = Watch_Node, this prints out the old and new nodes and
-   --  calls Rewrite_Breakpoint. Otherwise, does nothing.
-
procedure Node_Debug_Output (Op : String; N : Node_Id);
-   --  Common code for nnd and rrd, writes Op followed by information about N
+   --  Called by nnd; writes Op followed by information about N
 
procedure Print_Statistics;
pragma Export (Ada, Print_Statistics);
@@ -751,6 +736,8 @@
   Save_Link: constant Union_Id := Nodes.Table (Destination).Link;
 
begin
+  pragma Debug (New_Node_Debugging_Output (Source));
+  pragma Debug (New_Node_Debugging_Output (Destination));
   Nodes.Table (Destination) := Nodes.Table (Source);
   Nodes.Table (Destination).In_List := Save_In_List;
   Nodes.Table (Destination).Link:= Save_Link;
@@ -1348,6 +1335,8 @@
   Temp_Flg : Flags_Byte;
 
begin
+  pragma Debug (New_Node_Debugging_Output (E1));
+  pragma Debug (New_Node_Debugging_Output (E2));
   pragma Assert (True
 and then Has_Extension (E1)
 and then Has_Extension (E2)
@@ -1746,7 +1735,6 @@
begin
   Write_Str ("Watched node ");
   Write_Int (Int (Watch_Node));
-  Write_Str (" created");
   Write_Eol;
end nn;
 
@@ -1759,7 +1747,7 @@
 
begin
   if Debug_Flag_N or else Node_Is_Watched then
- Node_Debug_Output ("Allocate", N);
+ Node_Debug_Output ("Node", N);
 
  if Node_Is_Watched then
 New_Node_Breakpoint;
@@ -2163,6 +2151,8 @@
 (not Has_Extension (Old_Node)
   and not Has_Extension (New_Node)
   and not Nodes.Table (New_Node).In_List);
+  pragma Debug (New_Node_Debugging_Output (Old_Node));
+  pragma Debug (New_Node_Debugging_Output (New_Node));
 
   --  Do copy, preserving link and in list status and required flags
 
@@ -2214,7 +2204,8 @@
 (not Has_Extension (Old_Node)
   and not Has_Extension (New_Node)
   and not Nodes.Table (New_Node).In_List);
-  pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node));
+  pragma Debug (New_Node_Debugging_Output (Old_Node));
+  pragma Debug (New_Node_Debugging_Output (New_Node));
 
   if Nkind (Old_Node) in N_Subexpr then
  Old_Paren_Count := Paren_Count (Old_Node);
@@ -2264,36 +2255,6 @@
   end if;
end Rewrite;
 
-   -
-   -- Rewrite_Breakpoint --
-   -
-
-   procedure rr is
-   begin
-  Write_Str ("Watched node ");
-  Write_Int (Int (Watch_Node));
-  Write_Str (" rewritten");
-  Write_Eol;
-   end rr;
-
-   --
-   -- Rewrite_Debugging_Output --
-   --
-
-   procedure rrd (Old_Node, New_Node : Node_Id) is
-  Node_Is_Watched : constant Boolean := Old_Node = Watch_Node;
-
-   begin
-  if Debug_Flag_N or else Node_Is_Watched then
- Node_Debug_Output ("Rewrite", Old_Node);
- Node_Debug_Output ("into",

[Ada] Spurious error with predicate and class-wide object

[Pierre-Marie de Rodat]

This patch removes a spurious error on a call to a function that applies
to a predicated tagged type, when the actual in the call is class-wide.
The argument must be converted to be type-specific, given that the predicate
function is not dispatching and cannot accept a class-wide actual.

Executing:

   gnatmake -q -gnata main
   main

must yield:

   Predicate checked
   Predicate checked
   Predicate checked
   Predicate checked
   Predicate checked
   Predicate checked

---
with Predicate_Ints; use Predicate_Ints;
procedure Main is
  Thing1 : Int := (0, 100, 50);
  Thing2 : Approx_Int := (0, 100, 50, 13);
begin
  Call_Bump (Thing1);
  Call_Bump (Thing2);
end;
---
package Predicate_Ints is

   type Int is tagged record
  Min, Max, Value : Integer;
   end record
 with Predicate => Value in Min .. Max and then Checked;

   procedure Bump (Arg : in out Int);
   procedure Call_Bump (Arg : in out Int'Class);

   function Checked  return Boolean;

   type Approx_Int is new Int with record
  Precision : Natural;
   end record;

end Predicate_Ints;
---
with Text_IO; use Text_IO;
package body Predicate_Ints is
   function Checked return Boolean is
   begin
  Put_Line ("Predicate checked");
  return True;
   end;
   
   procedure Bump (Arg : in out Int) is
   begin
  Arg.Value := Arg.Value + 1;
   end Bump;

   procedure Call_Bump (Arg : in out Int'Class) is
   begin
  Arg.Bump;
   end Call_Bump;

end Predicate_Ints;

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

2017-10-09  Ed Schonberg  

* exp_util.adb (Make_Predicate_Call): If the type of the expression to
which the predicate check applies is tagged, convert the expression to
that type. This is in most cases a no-op, but is relevant if the
expression is clas-swide, because the predicate function being invoked
is not a primitive of the type and cannot take a class-wide actual.

Index: exp_util.adb
===
--- exp_util.adb(revision 253559)
+++ exp_util.adb(working copy)
@@ -9305,11 +9305,23 @@
 
   --  Case of calling normal predicate function
 
-  Call :=
-Make_Function_Call (Loc,
-  Name   => New_Occurrence_Of (Func_Id, Loc),
-  Parameter_Associations => New_List (Relocate_Node (Expr)));
+  --  If the type is tagged, the expression may be class-wide, in which
+  --  case it has to be converted to its root type, given that the
+  --  generated predicate function is not dispatching.
 
+  if Is_Tagged_Type (Typ) then
+ Call :=
+   Make_Function_Call (Loc,
+ Name   => New_Occurrence_Of (Func_Id, Loc),
+ Parameter_Associations =>
+   New_List (Convert_To (Typ, Relocate_Node (Expr;
+  else
+ Call :=
+   Make_Function_Call (Loc,
+ Name   => New_Occurrence_Of (Func_Id, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+  end if;
+
   Restore_Ghost_Mode (Saved_GM);
 
   return Call;

[Ada] Suppress generation of ABE checks in GNATprove mode

[Pierre-Marie de Rodat]

This patch suppresses the generation of ABE checks when compiling for GNATprove
because a) the checks are not needed and b) the checks involve raise statements
which are not supported by GNATprove. No need for a test.

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

2017-10-09  Hristian Kirtchev  

* sem_elab.adb (Install_ABE_Check): Do not generate an ABE check for
GNATprove.
(Install_ABE_Failure): Do not generate an ABE failure for GNATprove.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 253559)
+++ sem_elab.adb(working copy)
@@ -4199,9 +4199,15 @@
   Scop_Id : Entity_Id;
 
begin
+  --  Nothing to do when compiling for GNATprove because raise statements
+  --  are not supported.
+
+  if GNATprove_Mode then
+ return;
+
   --  Nothing to do when the compilation will not produce an executable
 
-  if Serious_Errors_Detected > 0 then
+  elsif Serious_Errors_Detected > 0 then
  return;
 
   --  Nothing to do for a compilation unit because there is no executable
@@ -4325,9 +4331,15 @@
--  Start for processing for Install_ABE_Check
 
begin
+  --  Nothing to do when compiling for GNATprove because raise statements
+  --  are not supported.
+
+  if GNATprove_Mode then
+ return;
+
   --  Nothing to do when the compilation will not produce an executable
 
-  if Serious_Errors_Detected > 0 then
+  elsif Serious_Errors_Detected > 0 then
  return;
 
   --  Nothing to do when the target is a protected subprogram because the
@@ -4381,9 +4393,15 @@
   Scop_Id : Entity_Id;
 
begin
+  --  Nothing to do when compiling for GNATprove because raise statements
+  --  are not supported.
+
+  if GNATprove_Mode then
+ return;
+
   --  Nothing to do when the compilation will not produce an executable
 
-  if Serious_Errors_Detected > 0 then
+  elsif Serious_Errors_Detected > 0 then
  return;
 
   --  Do not install an ABE check for a compilation unit because there is

[Ada] Spurious error in use of homograph of type name in predicate

[Pierre-Marie de Rodat]

This patch fixes a spurious error in an expression for a dynamic predicate,
when the name of (a homograph of) the type to which the predicate applies
is used in a context where the name cannot denote a current occurrence.

The following must compile quietly:

   gcc -c conv.ads

---
with Typ; use Typ;
package Conv  with SPARK_Mode is
private
   type U is new Typ.U with record
  X : Integer;
   end record
 with Dynamic_Predicate => Typ.U(U).Get > 0;
end Conv;
---
package Typ is
   type U is tagged private;
   function Get (V : U) return Integer;
private
   type U is tagged record
  Y : Integer;
   end record;

   function Get (V : U) return Integer is (V.Y);
end Typ;

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

2017-10-09  Ed Schonberg  

* sem_ch13.adb (Replace_Type_Ref): In the expression for a dynamic
predicate, do not replace an identifier that matches the type if the
identifier is a selector in a selected component, because this
indicates a reference to some homograph of the type itself, and  not to
the current occurence in the predicate.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 253546)
+++ sem_ch13.adb(working copy)
@@ -4415,15 +4415,6 @@
 
 if Present (Default_Element) then
Analyze (Default_Element);
-
-   if Is_Entity_Name (Default_Element)
- and then not Covers (Entity (Default_Element), Ret_Type)
- and then False
-   then
-  Illegal_Indexing
-("wrong return type for indexing function");
-  return;
-   end if;
 end if;
 
 --  For variable_indexing the return type must be a reference type
@@ -12670,10 +12661,18 @@
 
return Skip;
 
---  Otherwise do the replacement and we are done with this node
+--  Otherwise do the replacement if this is not a qualified
+--  reference to a homograph of the type itself. Note that the
+--  current instance could not appear in such a context, e.g.
+--  the prefix of a type conversion.
 
 else
-   Replace_Type_Reference (N);
+   if Nkind (Parent (N)) /= N_Selected_Component
+ or else N /= Selector_Name (Parent (N))
+   then
+  Replace_Type_Reference (N);
+   end if;
+
return Skip;
 end if;
 
@@ -12682,7 +12681,7 @@
 
  elsif Nkind (N) = N_Selected_Component then
 
---  If selector name is not our type, keeping going (we might still
+--  If selector name is not our type, keep going (we might still
 --  have an occurrence of the type in the prefix).
 
 if Nkind (Selector_Name (N)) /= N_Identifier

[Ada] Rewrite check for SPARK RM 7.1.3(10)

[Pierre-Marie de Rodat]

The evolution of SPARK RM 7.1.3(10) rule was not followed by code that
implements it. The current wording is:

   "If a procedure has an in mode parameter of an effectively volatile type,
then the Effective_Reads aspect of any corresponding actual parameter
shall be False."

and the current code checks exactly that.


-- Source --


--  ineffective_actual.ads

with System;

package Ineffective_Actual
with
   SPARK_Mode
is
   type VT is 
  record
 Int : Integer;
  end record
   with Volatile;

   The_Volatile_Data : VT
   with
  Volatile,
  Async_Readers=> True,
  Async_Writers=> True,
  Effective_Reads  => False,
  Effective_Writes => False,
  Address => System'To_Address (16#1234_5678#);

   procedure Harmless_Reader (Data : in VT);

   procedure Do_Something;

end Ineffective_Actual;

--  ineffective_actual.adb

package body Ineffective_Actual
with
   SPARK_Mode
is
   procedure Harmless_Reader (Data : in VT)
   with
  SPARK_Mode => Off
   is
  I : Integer;
   begin
  I := Data.Int;
   end Harmless_Reader;

   procedure Do_Something
   is
   begin
  Harmless_Reader (The_Volatile_Data);
   end Do_Something;
end Ineffective_Actual;


-- Compilation and output --


& gcc -c ineffective_actual.adb
& gcc -c -gnatd.F ineffective_actual.adb

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

2017-10-09  Piotr Trojanek  

* sem_res.adb (Property_Error): Remove.
(Resolve_Actuals): check for SPARK RM 7.1.3(10) rewritten to match the
current wording of the rule.

Index: sem_res.adb
===
--- sem_res.adb (revision 253559)
+++ sem_res.adb (working copy)
@@ -3178,14 +3178,6 @@
   --  an instance of the default expression. The insertion is always
   --  a named association.
 
-  procedure Property_Error
-(Var  : Node_Id;
- Var_Id   : Entity_Id;
- Prop_Nam : Name_Id);
-  --  Emit an error concerning variable Var with entity Var_Id that has
-  --  enabled property Prop_Nam when it acts as an actual parameter in a
-  --  call and the corresponding formal parameter is of mode IN.
-
   function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
   --  Check whether T1 and T2, or their full views, are derived from a
   --  common type. Used to enforce the restrictions on array conversions
@@ -3634,23 +3626,6 @@
  Prev := Actval;
   end Insert_Default;
 
-  
-  -- Property_Error --
-  
-
-  procedure Property_Error
-(Var  : Node_Id;
- Var_Id   : Entity_Id;
- Prop_Nam : Name_Id)
-  is
-  begin
- Error_Msg_Name_1 := Prop_Nam;
- Error_Msg_NE
-   ("external variable & with enabled property % cannot appear as "
-& "actual in procedure call (SPARK RM 7.1.3(10))", Var, Var_Id);
- Error_Msg_N ("\\corresponding formal parameter has mode In", Var);
-  end Property_Error;
-
   ---
   -- Same_Ancestor --
   ---
@@ -4659,26 +4634,28 @@
   Flag_Effectively_Volatile_Objects (A);
end if;
 
-   --  Detect an external variable with an enabled property that
-   --  does not match the mode of the corresponding formal in a
-   --  procedure call. Functions are not considered because they
-   --  cannot have effectively volatile formal parameters in the
-   --  first place.
+   --  An effectively volatile variable cannot act as an actual
+   --  parameter in a procedure call when the variable has enabled
+   --  property Effective_Reads and the corresponding formal is of
+   --  mode IN (SPARK RM 7.1.3(10)).
 
if Ekind (Nam) = E_Procedure
  and then Ekind (F) = E_In_Parameter
  and then Is_Entity_Name (A)
- and then Present (Entity (A))
- and then Ekind (Entity (A)) = E_Variable
then
   A_Id := Entity (A);
 
-  if Async_Readers_Enabled (A_Id) then
- Property_Error (A, A_Id, Name_Async_Readers);
-  elsif Effective_Reads_Enabled (A_Id) then
- Property_Error (A, A_Id, Name_Effective_Reads);
-  elsif Effective_Writes_Enabled (A_Id) then
- Property_Error (A, A_Id, Name_Effective_Writes);
+  if Ekind (A_Id) = E_Variable
+and then Is_Effectively_Volatile (Etype (A_Id))
+and then Effective_Reads_Enabled (A_Id)
+  then
+ Error_Msg_NE
+   ("effectively volatile variable & cannot 

[Ada] Internal error on expression function in ghost package

[Pierre-Marie de Rodat]

This patch corrects an issue whereby an expression function within a ghost
package would cause orphaned freeze nodes.


-- Source --


--  p.ads

package P
  with SPARK_Mode
is
   type Rec is record
  I : Integer;
   end record;
   package Inner with Ghost is
  function F (I : Integer) return Integer is (I);
  function Zero (B : Rec) return Integer;
   end Inner;
   procedure Proc (B : Rec);
end P;

--  p.adb

package body P
  with SPARK_Mode
is
   package body Inner is
  function Zero (B : Rec) return Integer is
  begin
 return 0;
  end;
   end Inner;
   procedure Proc (B : Rec) is
   begin
   if B.I = 0 then
  raise Program_Error;
   end if;
   end;
end P;

--  buffers.ads

with Ada.Containers.Functional_Vectors;
package Buffers
  with SPARK_Mode
is
   subtype Resource is Natural range 0 .. 1000;
   subtype Num is Natural range 0 .. 6;
   subtype Index is Num range 1 .. 6;
   type Data is array (Index) of Resource;
   type Buffer is record
  D : Data;
  K : Index;
   end record;
   package Models with Ghost is
  package Seqs is new Ada.Containers.Functional_Vectors (Index, Resource);
  use Seqs;
  function Rotate_Right (S : Sequence) return Sequence is
(Add (Remove (S, First), Get (S, First)));
  function Model (B : Buffer) return Sequence;
   end Models;
   use Models;
   use Models.Seqs;
   procedure Bump (B : in out Buffer) with
 Post => Model(B) = Model(B);
end Buffers;

--  buffers.adb

with Ada.Containers.Functional_Vectors;
package body Buffers
  with SPARK_Mode
is
   package body Models is
  function Model (B : Buffer) return Sequence is
 S : Sequence;
  begin
 for J in B.K .. Index'Last loop
S := Add (S, B.D(J));
 end loop;
 for J in Index'First .. B.K-1 loop
S := Add (S, B.D(J));
 end loop;
 return S;
  end Model;
   end Models;
   procedure Bump (B : in out Buffer) is
   begin
  if B.K = Index'Last then
 B.K := Index'First;
  else
 B.K := B.K + 1;
  end if;
   end Bump;
end Buffers;


-- Compilation and output --


& gcc -c buffers.adb
& gcc -c p.adb

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

2017-10-09  Justin Squirek  

* sem_ch3.adb (Analyze_Declarations): Add check for ghost packages
before analyzing a given scope due to an expression function.
(Uses_Unseen_Lib_Unit_Priv): Rename to Uses_Unseen_Priv.

Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 253559)
+++ sem_ch3.adb (working copy)
@@ -2233,9 +2233,11 @@
   --  Utility to resolve the expressions of aspects at the end of a list of
   --  declarations.
 
-  function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
-  --  Check if an inner package has entities within it that rely on library
-  --  level private types where the full view has not been seen.
+  function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean;
+  --  Check if a nested package has entities within it that rely on library
+  --  level private types where the full view has not been seen for the
+  --  purposes of checking if it is acceptable to freeze an expression
+  --  function at the point of declaration.
 
   -
   -- Adjust_Decl --
@@ -2540,11 +2542,11 @@
  end loop;
   end Resolve_Aspects;
 
-  ---
-  -- Uses_Unseen_Lib_Unit_Priv --
-  ---
+  --
+  -- Uses_Unseen_Priv --
+  --
 
-  function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
+  function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean is
  Curr : Entity_Id;
 
   begin
@@ -2572,7 +2574,7 @@
  end if;
 
  return False;
-  end Uses_Unseen_Lib_Unit_Priv;
+  end Uses_Unseen_Priv;
 
   --  Local variables
 
@@ -2753,8 +2755,9 @@
 
  elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
and then ((Nkind (Next_Decl) /= N_Subprogram_Body
-  or else not Was_Expression_Function (Next_Decl))
- or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
+   or else not Was_Expression_Function (Next_Decl))
+  or else (not Is_Ignored_Ghost_Entity (Current_Scope)
+and then not Uses_Unseen_Priv (Current_Scope)))
  then
 --  When a controlled type is frozen, the expander generates stream
 --  and controlled-type support routines. If the freeze is caused

[Ada] Spurious warnings with dynamic elab checks

[Pierre-Marie de Rodat]

This patch classifies 'Access, variable assignments, and variable references as
static model-only scenarios because they are graph-dependent and do not produce
any checks. No need for a test.

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

2017-10-09  Hristian Kirtchev  

* sem_elab.adb (Is_Suitable_Access): This scenario is now only relevant
in the static model.
(Is_Suitable_Variable_Assignment): This scenario is now only relevant
in the static model.
(Is_Suitable_Variable_Reference): This scenario is now only relevant in
the static model.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 253563)
+++ sem_elab.adb(working copy)
@@ -4995,11 +4995,27 @@
   Subp_Id : Entity_Id;
 
begin
-  if Nkind (N) /= N_Attribute_Reference then
+  --  This scenario is relevant only when the static model is in effect
+  --  because it is graph-dependent and does not involve any run-time
+  --  checks. Allowing it in the dynamic model would create confusing
+  --  noise.
+
+  if not Static_Elaboration_Checks then
  return False;
 
-  --  Internally-generated attributes are assumed to be ABE safe
+  --  Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
 
+  elsif Debug_Flag_Dot_UU then
+ return False;
+
+  --  Nothing to do when the scenario is not an attribute reference
+
+  elsif Nkind (N) /= N_Attribute_Reference then
+ return False;
+
+  --  Nothing to do for internally-generated attributes because they are
+  --  assumed to be ABE safe.
+
   elsif not Comes_From_Source (N) then
  return False;
   end if;
@@ -5031,16 +5047,10 @@
 
   return
 
---  This particular scenario is relevant only in the static model when
---  switch -gnatd.U (ignore 'Access) is not in effect.
+--  The prefix must denote a source entry, operator, or subprogram
+--  which is not imported.
 
-Static_Elaboration_Checks
-  and then not Debug_Flag_Dot_UU
-
-  --  The prefix must denote an entry, operator, or subprogram which is
-  --  not imported.
-
-  and then Comes_From_Source (Subp_Id)
+Comes_From_Source (Subp_Id)
   and then Is_Subprogram_Or_Entry (Subp_Id)
   and then not Is_Bodiless_Subprogram (Subp_Id)
 
@@ -5109,11 +5119,22 @@
   Var_Unit_Id : Entity_Id;
 
begin
-  if Nkind (N) /= N_Assignment_Statement then
+  --  This scenario is relevant only when the static model is in effect
+  --  because it is graph-dependent and does not involve any run-time
+  --  checks. Allowing it in the dynamic model would create confusing
+  --  noise.
+
+  if not Static_Elaboration_Checks then
  return False;
 
-  --  Internally-generated assigments are assumed to be ABE safe
+  --  Nothing to do when the scenario is not an assignment
 
+  elsif Nkind (N) /= N_Assignment_Statement then
+ return False;
+
+  --  Nothing to do for internally-generated assignments because they are
+  --  assumed to be ABE safe.
+
   elsif not Comes_From_Source (N) then
  return False;
 
@@ -5161,10 +5182,10 @@
   --  To qualify, the assignment must meet the following prerequisites:
 
   return
-Comes_From_Source (Var_Id)
 
-  --  The variable must be susceptible to warnings
+--  The variable must be a source entity and susceptible to warnings
 
+Comes_From_Source (Var_Id)
   and then not Has_Warnings_Off (Var_Id)
 
   --  The variable must be declared in the spec of compilation unit U
@@ -5232,14 +5253,23 @@
--  Start of processing for Is_Suitable_Variable_Reference
 
begin
+  --  This scenario is relevant only when the static model is in effect
+  --  because it is graph-dependent and does not involve any run-time
+  --  checks. Allowing it in the dynamic model would create confusing
+  --  noise.
+
+  if not Static_Elaboration_Checks then
+ return False;
+
   --  Attributes and operator sumbols are not considered to be suitable
   --  references to variables even though they are part of predicate
   --  Is_Entity_Name.
 
-  if not Nkind_In (N, N_Expanded_Name, N_Identifier) then
+  elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
  return False;
 
-  --  Internally generated references are assumed to be ABE safe
+  --  Nothing to do for internally-generated references because they are
+  --  assumed to be ABE safe.
 
   elsif not Comes_From_Source (N) then
  return False;

[Ada] Support for reverse iteration on formal containers

[Pierre-Marie de Rodat]

This patch adds support for reverse iterations over formal containers,
analogous to what is supported on arrays and predefined containers.

Executing:

  gnatmake -q foo
  foo

must yield;

 1 2 3 4 5 6 7 8 9 10
 10 9 8 7 6 5 4 3 2 1
 10 9 8 7 6 5 4 3 2 1

---
with Ada.Text_IO; use Ada.Text_IO;

procedure Foo is
   type Int_Range is record
  First, Last : Integer;
   end record
  with Iterable => (First => First,
Next => Next,
Previous => Previous,
Last => Last,
Has_Element => Has_Element,
Element => Element);

   function First (IR : Int_Range) return Integer is (IR.First);
   function Last (IR : Int_Range) return Integer is (IR.Last);
   function Next (IR : Int_Range; N : Integer) return Integer is (N + 1);
   function Previous (IR : Int_Range; N : Integer) return Integer is (N - 1);
   function Has_Element (IR : Int_Range; N : Integer) return Boolean is
 (N in IR.First ..IR.Last);
   function Element (IR : Int_Range; N : Integer) return Integer is (N);

   IR : Int_Range := (1, 10);
begin
   for I of IR loop
  Put (I'Img);
   end loop;
   New_Line;

   for I in reverse IR loop
  Put (I'Img);
   end loop;
   New_Line;

   for I of reverse IR loop
  Put (I'Img);
   end loop;
end Foo;

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

2017-10-09  Ed Schonberg  

* sem_ch5.adb (Analyze_Iterator_Specification,
Check_Reverse_Iteration): Check that the domain of iteration supports
reverse iteration when it is a formal container.  This requires the
presence of a Previous primitive in the Iterable aspect.
* sem_ch13.adb (Resolve_Iterable_Operation): Verify legality of
primitives Last and Previous to support reverse iteration over formal
containers.
(Validate_Iterable_Aspect): Add check for reverse iteration operations.
* exp_ch5.adb (Build_Formal_Container_Iteration): Add proper expansion
for reverse iteration using primitives Last and Previous in generated
loop.

Index: exp_ch5.adb
===
--- exp_ch5.adb (revision 253566)
+++ exp_ch5.adb (working copy)
@@ -178,14 +178,27 @@
   Loc  : constant Source_Ptr := Sloc (N);
   Stats: constant List_Id:= Statements (N);
   Typ  : constant Entity_Id  := Base_Type (Etype (Container));
-  First_Op : constant Entity_Id  :=
-   Get_Iterable_Type_Primitive (Typ, Name_First);
-  Next_Op  : constant Entity_Id  :=
-   Get_Iterable_Type_Primitive (Typ, Name_Next);
 
+  First_Op : Entity_Id;
+  Next_Op  : Entity_Id;
+
   Has_Element_Op : constant Entity_Id :=
Get_Iterable_Type_Primitive (Typ, Name_Has_Element);
begin
+  --  Use the proper set of primitives depending on the direction of
+  --  iteration. The legality of a reverse iteration has been checked
+  --  during analysis.
+
+  if Reverse_Present (Iterator_Specification (Iteration_Scheme (N))) then
+ First_Op := Get_Iterable_Type_Primitive (Typ, Name_Last);
+ Next_Op  := Get_Iterable_Type_Primitive (Typ, Name_Previous);
+
+  else
+ First_Op := Get_Iterable_Type_Primitive (Typ, Name_First);
+ Next_Op  := Get_Iterable_Type_Primitive (Typ, Name_Next);
+ null;
+  end if;
+
   --  Declaration for Cursor
 
   Init :=
@@ -198,7 +211,7 @@
   Parameter_Associations => New_List (
 Convert_To_Iterable_Type (Container, Loc;
 
-  --  Statement that advances cursor in loop
+  --  Statement that advances (in the right direction) cursor in loop
 
   Advance :=
 Make_Assignment_Statement (Loc,
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 253563)
+++ sem_ch13.adb(working copy)
@@ -13200,10 +13200,13 @@
 
  Ent := Entity (N);
  F1 := First_Formal (Ent);
- if Nam = Name_First then
 
---  First (Container) => Cursor
+ if Nam = Name_First
+   or else Nam = Name_Last
+ then
 
+--  First or Last (Container) => Cursor
+
 if Etype (Ent) /= Cursor then
Error_Msg_N ("primitive for First must yield a curosr", N);
 end if;
@@ -13221,6 +13224,19 @@
Error_Msg_N ("no match for Next iterable primitive", N);
 end if;
 
+ elsif Nam = Name_Previous then
+
+--  Previous (Container, Cursor) => Cursor
+
+F2 := Next_Formal (F1);
+
+if Etype (F2) /= Cursor
+  or else Etype (Ent) /= Cursor
+  or else Present (Next_Formal (F2))
+then
+   Error_Msg_N ("no match for Previous iterable primitive", N);
+end if;
+
   

[Ada] Check elaboration requirement for SPARK in the static model

[Pierre-Marie de Rodat]

This patch ensures that the Elaborate[_All] requirement imposed on the context
of a unit in SPARK code is verified only when the static model is in effect.


-- Source --


--  server.ads

package Server with SPARK_Mode is
   function Read return Integer;
end Server;

--  server.adb

package body Server with SPARK_Mode is
   function Read return Integer is
   begin
  return 0;
   end Read;
end Server;

--  client.ads

package Client with SPARK_Mode is
   function Prf return Boolean;
end Client;

--  client.adb

with Server;

package body Client with SPARK_Mode is
   function Prf return Boolean is
   begin
  return Server.Read = 0;
   end Prf;
end Client;

-
-- Compilation --
-

$ gcc -c client.adb
$ gcc -c client.adb -gnatE

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

2017-10-09  Hristian Kirtchev  

* sem_elab.adb (Static_Elaboration_Checks): Elaboration requirements
are verified only in the static model.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 253564)
+++ sem_elab.adb(working copy)
@@ -5516,12 +5516,18 @@
 
   Req_Met := False;
 
+  --  Elaboration requirements are verified only when the static model is
+  --  in effect because this diagnostic is graph-dependent.
+
+  if not Static_Elaboration_Checks then
+ return;
+
   --  If the target is within the main unit, either at the source level or
   --  through an instantiation, then there is no real requirement to meet
   --  because the main unit cannot force its own elaboration by means of an
   --  Elaborate[_All] pragma. Treat this case as valid coverage.
 
-  if In_Extended_Main_Code_Unit (Target_Id) then
+  elsif In_Extended_Main_Code_Unit (Target_Id) then
  Req_Met := True;
 
   --  Otherwise the target resides in an external unit

[Ada] Crash on child unit name with -gnatdJ

[Pierre-Marie de Rodat]

When the debugging switch -gnatdJ is present, warning messages include the
name of the unit within which the warning is generated. This patch fixes
a crash in the compiler when a warning appears within a child unit.

The command

  gcc -c -gnatdJ test-a.ads

must yield; 

test-a.ads:6:17: warning: Test.A: unused variable "X"

---
package Test is
end Test;
---
with Test;

package Test.A is

function P return Natural is (3) with
Pre => (for all X in Natural => True);

end Test.A;

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

2017-10-09  Ed Schonberg  

* sem_util.adb (Subprogram_Name): If this is a child unit, use the name
of the Defining_Program_Unit_Name, which is an identifier, in order to
construct the string for the fully qualified name.

Index: sem_util.adb
===
--- sem_util.adb(revision 253559)
+++ sem_util.adb(working copy)
@@ -23257,7 +23257,16 @@
  return "unknown subprogram";
   end if;
 
-  Append_Entity_Name (Buf, Ent);
+  if Nkind (Ent) = N_Defining_Program_Unit_Name then
+
+ --  If the subprogram is a child unit, use its simple name to
+ --  start the construction of the fully qualified name.
+
+ Append_Entity_Name (Buf, Defining_Identifier (Ent));
+
+  else
+ Append_Entity_Name (Buf, Ent);
+  end if;
   return +Buf;
end Subprogram_Name;
 

[Ada] Crash on potential access-before-elaboration in ZFP

[Pierre-Marie de Rodat]

This patch update the mechanism which retrieves the enclosing scope of a node
to account for blocks produces by exception handler expansion. These blocks are
not scoping constructs and should not be considered. As a result, an access-
before-elaboration check will no longer cause a crash on ZFP.


-- Source --


--  pack.ads

package Pack is
   procedure Force_Body;
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   procedure Force_Body is begin null; end Force_Body;

   package Nested is
  function Func (Val : Integer) return Integer;
   end Nested;

   package body Nested is
  procedure Proc is
 Val : Integer;

  begin
 Val := Func (1);
 Put_Line ("ERROR: Program_Error not raised");
  exception
 when Program_Error =>
Put_Line ("OK");
 when others =>
Put_Line ("ERROR: unexpected exception");
  end Proc;

  package Elaborator is
  end Elaborator;

  package body Elaborator is
  begin
 Proc;
  end Elaborator;

  function Func (Val : Integer) return Integer is
  begin
 return Val + 1;
  end Func;
   end Nested;
end Pack;

-
-- Compilation --
-

$ gcc -c -gnatws --RTS=zfp pack.adb

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

2017-10-09  Hristian Kirtchev  

* sem_unit.adb (Find_Enclosing_Scope): Do not treat a block statement
as a scoping construct when it is byproduct of exception handling.

Index: sem_util.adb
===
--- sem_util.adb(revision 253567)
+++ sem_util.adb(working copy)
@@ -7929,13 +7929,21 @@
 
 --  Special cases
 
---  Blocks, loops, and return statements have artificial scopes
+--  Blocks carry either a source or an internally-generated scope,
+--  unless the block is a byproduct of exception handling.
 
-when N_Block_Statement
-   | N_Loop_Statement
-=>
+when N_Block_Statement =>
+   if not Exception_Junk (Par) then
+  return Entity (Identifier (Par));
+   end if;
+
+--  Loops carry an internally-generated scope
+
+when N_Loop_Statement =>
return Entity (Identifier (Par));
 
+--  Extended return statements carry an internally-generated scope
+
 when N_Extended_Return_Statement =>
return Return_Statement_Entity (Par);
 
@@ -19511,13 +19519,13 @@
  N := Next (Actual_Id);
 
  if Nkind (N) = N_Parameter_Association then
+
 --  In case of a build-in-place call, the call will no longer be a
 --  call; it will have been rewritten.
 
-if Nkind_In (Parent (Actual_Id),
- N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
+if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
 then
return First_Named_Actual (Parent (Actual_Id));
 else
@@ -23257,16 +23265,15 @@
  return "unknown subprogram";
   end if;
 
+  --  If the subprogram is a child unit, use its simple name to start the
+  --  construction of the fully qualified name.
+
   if Nkind (Ent) = N_Defining_Program_Unit_Name then
-
- --  If the subprogram is a child unit, use its simple name to
- --  start the construction of the fully qualified name.
-
  Append_Entity_Name (Buf, Defining_Identifier (Ent));
-
   else
  Append_Entity_Name (Buf, Ent);
   end if;
+
   return +Buf;
end Subprogram_Name;
 

[Ada] Update the categorization of N_Call_Marker nodes

[Pierre-Marie de Rodat]

This patch update the categorization of node N_Call_Marker's fields. No change
in behaviour, no need for a test.

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

2017-10-09  Hristian Kirtchev  

* sinfo.ads: Update table Is_Syntactic_Field to reflect the nature of
semantic field Target of node N_Call_Marker.

Index: exp_aggr.adb
===
--- exp_aggr.adb(revision 253567)
+++ exp_aggr.adb(working copy)
@@ -4125,25 +4125,6 @@
-- Convert_To_Assignments --

 
-   function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
-  P : Node_Id := Parent (N);
-   begin
-  while Nkind (P) = N_Qualified_Expression loop
- P := Parent (P);
-  end loop;
-
-  if Nkind (P) = N_Simple_Return_Statement then
- null;
-  elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
- P := Parent (P);
-  else
- return False;
-  end if;
-
-  return Is_Build_In_Place_Function
-(Return_Applies_To (Return_Statement_Entity (P)));
-   end Is_Build_In_Place_Aggregate_Return;
-
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
   Loc  : constant Source_Ptr := Sloc (N);
   T: Entity_Id;
@@ -4176,8 +4157,9 @@
 Unc_Decl :=
   not Is_Entity_Name (Object_Definition (Parent_Node))
 or else (Nkind (N) = N_Aggregate
-   and then Has_Discriminants
- (Entity (Object_Definition (Parent_Node
+  and then
+Has_Discriminants
+  (Entity (Object_Definition (Parent_Node
 or else Is_Class_Wide_Type
   (Entity (Object_Definition (Parent_Node)));
  end if;
@@ -6671,8 +6653,8 @@
--  individual assignments to the given components.
 
procedure Expand_N_Extension_Aggregate (N : Node_Id) is
+  A   : constant Node_Id:= Ancestor_Part (N);
   Loc : constant Source_Ptr := Sloc (N);
-  A   : constant Node_Id:= Ancestor_Part (N);
   Typ : constant Entity_Id  := Etype (N);
 
begin
@@ -7476,6 +7458,33 @@
   return False;
end Has_Default_Init_Comps;
 
+   
+   -- Is_Build_In_Place_Aggregate_Return --
+   
+
+   function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
+  P : Node_Id := Parent (N);
+
+   begin
+  while Nkind (P) = N_Qualified_Expression loop
+ P := Parent (P);
+  end loop;
+
+  if Nkind (P) = N_Simple_Return_Statement then
+ null;
+
+  elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
+ P := Parent (P);
+
+  else
+ return False;
+  end if;
+
+  return
+Is_Build_In_Place_Function
+  (Return_Applies_To (Return_Statement_Entity (P)));
+   end Is_Build_In_Place_Aggregate_Return;
+
--
-- Is_Delayed_Aggregate --
--
Index: exp_ch3.adb
===
--- exp_ch3.adb (revision 253567)
+++ exp_ch3.adb (working copy)
@@ -1712,7 +1712,8 @@
   Set_Tag   : Entity_Id := Empty;
 
   function Build_Assignment
-(Id : Entity_Id; Default : Node_Id) return List_Id;
+(Id  : Entity_Id;
+ Default : Node_Id) return List_Id;
   --  Build an assignment statement that assigns the default expression to
   --  its corresponding record component if defined. The left-hand side of
   --  the assignment is marked Assignment_OK so that initialization of
@@ -1785,10 +1786,11 @@
   --
 
   function Build_Assignment
-(Id : Entity_Id; Default : Node_Id) return List_Id
+(Id  : Entity_Id;
+ Default : Node_Id) return List_Id
   is
  Default_Loc : constant Source_Ptr := Sloc (Default);
- Typ   : constant Entity_Id := Underlying_Type (Etype (Id));
+ Typ : constant Entity_Id  := Underlying_Type (Etype (Id));
 
  Adj_Call : Node_Id;
  Exp  : Node_Id   := Default;
@@ -1871,7 +1873,7 @@
 
  if Kind = N_Attribute_Reference
and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
-Name_Unrestricted_Access)
+  Name_Unrestricted_Access)
and then Is_Entity_Name (Prefix (Default))
and then Is_Type (Entity (Prefix (Default)))
and then Entity (Prefix (Default)) = Rec_Type
@@ -1915,9 +1917,8 @@
 Expression =>
   Unchecked_Convert_To (RTE (RE_Tag),
 New_Occurrence_Of
-  (Node
-

[Ada] Missing error on implicit copy of limited value in expression function

[Pierre-Marie de Rodat]

This patch corrects an omission on the legality check of an allocator whose
expression is of a limited type, when the allocator is the expression of an
expression function.

Compiling t3.adb must yield:

  t3.adb:4:13: warning: not dispatching (must be defined in a package spec)
  t3.adb:5:07: initialization not allowed for limited types

---
procedure T3 is
   type X_T is tagged limited null record;
   type A_T is access X_T'Class;
   function Clone (X : X_T) return A_T is
 (new X_T'Class' (X_T'Class (X)));
   X : X_T;
   A : A_T := Clone (X);
begin
   null;
end T3;

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

2017-10-09  Ed Schonberg  

* sem_res.adb (Resolve_Allocator): Reject properly an allocator that
attempts to copy a limited value, when the allocator is the expression
in an expression function.

Index: sem_res.adb
===
--- sem_res.adb (revision 253563)
+++ sem_res.adb (working copy)
@@ -4834,10 +4834,18 @@
  --  are explicitly marked as coming from source but do not need to be
  --  checked for limited initialization. To exclude this case, ensure
  --  that the parent of the allocator is a source node.
+ --  The return statement constructed for an Expression_Function does
+ --  not come from source but requires a limited check.
 
  if Is_Limited_Type (Etype (E))
and then Comes_From_Source (N)
-   and then Comes_From_Source (Parent (N))
+   and then
+ (Comes_From_Source (Parent (N))
+   or else
+ (Ekind (Current_Scope) = E_Function
+   and then Nkind
+ (Original_Node (Unit_Declaration_Node (Current_Scope)))
+   = N_Expression_Function))
and then not In_Instance_Body
  then
 if not OK_For_Limited_Init (Etype (E), Expression (E)) then

[Ada] Small optimizations in Sem_Type.Covers

[Pierre-Marie de Rodat]

The Sem_Type.Covers predicate is by far the topmost subprogram in the profile
of unoptimized compilations in Ada.  This change contains a series of small
optimizations that save about 2% of the instruction count on x86-64:

  1. Inline 3 more predicates from einfo,
  2. Simplify a convoluted condition dealing with Standard_Void_Type,
  3. Move up cheap tests on T2 so that they are executed before more costly
 tests on T1,
  4. Move the Is_Private_Type test from Full_View_Covers to the main body
 and remove tests on base types that were already done in the main body.

The main saving stems from 4. because tests on In_Instance are now guarded
by the Is_Private_Type predicate and In_Instance is quite costly since it
climbs the scope chain on each invocation.

No functional changes.

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

2017-10-09  Eric Botcazou  

* einfo.ads (Is_Boolean_Type): Add pragma Inline.
(Is_Entity_Name): Likewise.
(Is_String_Type): Likewise.
* sem_type.adb (Full_View_Covers): Do not test Is_Private_Type here
and remove useless comparisons on the base types.
(Covers): Use simple tests for Standard_Void_Type.  Move up cheap tests
on T2.  Always test Is_Private_Type before Full_View_Covers.

Index: einfo.ads
===
--- einfo.ads   (revision 253559)
+++ einfo.ads   (working copy)
@@ -9470,9 +9470,12 @@
 
pragma Inline (Base_Type);
pragma Inline (Is_Base_Type);
+   pragma Inline (Is_Boolean_Type);
pragma Inline (Is_Controlled);
+   pragma Inline (Is_Entity_Name);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
+   pragma Inline (Is_String_Type);
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
Index: sem_type.adb
===
--- sem_type.adb(revision 253546)
+++ sem_type.adb(working copy)
@@ -761,15 +761,19 @@
 
   function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
   begin
- return
-   Is_Private_Type (Typ1)
- and then
-  ((Present (Full_View (Typ1))
- and then Covers (Full_View (Typ1), Typ2))
-or else (Present (Underlying_Full_View (Typ1))
-  and then Covers (Underlying_Full_View (Typ1), Typ2))
-or else Base_Type (Typ1) = Typ2
-or else Base_Type (Typ2) = Typ1);
+ if Present (Full_View (Typ1))
+   and then Covers (Full_View (Typ1), Typ2)
+ then
+return True;
+
+ elsif Present (Underlying_Full_View (Typ1))
+   and then Covers (Underlying_Full_View (Typ1), Typ2)
+ then
+return True;
+
+ else
+return False;
+ end if;
   end Full_View_Covers;
 
   -
@@ -825,7 +829,7 @@
   --  Standard_Void_Type is a special entity that has some, but not all,
   --  properties of types.
 
-  if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
+  if T1 = Standard_Void_Type or else T2 = Standard_Void_Type then
  return False;
   end if;
 
@@ -892,8 +896,8 @@
 or else (T2 = Universal_Realand then Is_Real_Type (T1))
 or else (T2 = Universal_Fixed   and then Is_Fixed_Point_Type (T1))
 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
+or else (T2 = Any_Character and then Is_Character_Type (T1))
 or else (T2 = Any_Stringand then Is_String_Type (T1))
-or else (T2 = Any_Character and then Is_Character_Type (T1))
 or else (T2 = Any_Accessand then Is_Access_Type (T1))
   then
  return True;
@@ -916,9 +920,9 @@
   --  task_type or protected_type that implements the interface.
 
   elsif Ada_Version >= Ada_2005
+and then Is_Concurrent_Type (T2)
 and then Is_Class_Wide_Type (T1)
 and then Is_Interface (Etype (T1))
-and then Is_Concurrent_Type (T2)
 and then Interface_Present_In_Ancestor
(Typ => BT2, Iface => Etype (T1))
   then
@@ -928,9 +932,9 @@
   --  object T2 implementing T1.
 
   elsif Ada_Version >= Ada_2005
+and then Is_Tagged_Type (T2)
 and then Is_Class_Wide_Type (T1)
 and then Is_Interface (Etype (T1))
-and then Is_Tagged_Type (T2)
   then
  if Interface_Present_In_Ancestor (Typ   => T2,
Iface => Etype (T1))
@@ -1183,19 +1187,16 @@
   --  whether a partial and a full view match. Verify that types are
   --  legal, to prevent cascaded errors.
 
-  elsif In_Instance
-and then (Full_View_Covers (T1, T2) or else Full_View_Covers (T2, T1))
-  then
- 

Re: [PATCH] [PR82155] Fix crash in dwarf2out_abstract_function

[Pierre-Marie de Rodat]

Hello Richard,

On 09/25/2017 01:54 PM, Richard Biener wrote:

Ok for trunk and gcc-7 branch after a while.

Is it still okay to commit to gcc-7, now?

--
Pierre-Marie de Rodat

[Ada] Fix incorrect assignment to array with Component_Size clause

[Pierre-Marie de Rodat]

This change fixes a wrong translation of the assignment of an aggregate
made up of a single Others choice to an array whose nominal size of the
component type is the storage unit and which is subject to a Component_Size
clause that effectively bumps this size.

The compiler was generating a call to memset in this case, which filled
the gap between the nominal size and the component size with copies of
the single Others value instead of zero/sign-extending it appropriately.

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

gcc/ada/

2017-12-15  Eric Botcazou  

* exp_aggr.adb: Fix for QC04-027 (incorrect assignment to array
with Component_Size clause):

* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Use
Component_Size of the innermost array instead of Esize of its
component type to exclude inappropriate array types, including
packed array types.

gcc/testsuite/

2017-12-15  Eric Botcazou  

* gnat.dg/component_size.adb: New testcase.
Index: exp_aggr.adb
===
--- exp_aggr.adb(revision 255693)
+++ exp_aggr.adb(working copy)
@@ -4895,14 +4895,14 @@
 
   --1. N consists of a single OTHERS choice, possibly recursively
 
-  --2. The array type is not packed
+  --2. The array type has no null ranges (the purpose of this is to
+  --   avoid a bogus warning for an out-of-range value).
 
   --3. The array type has no atomic components
 
-  --4. The array type has no null ranges (the purpose of this is to
-  --   avoid a bogus warning for an out-of-range value).
+  --4. The component type is elementary
 
-  --5. The component type is elementary
+  --5. The component size is a multiple of Storage_Unit
 
   --6. The component size is Storage_Unit or the value is of the form
   --   M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
@@ -4918,6 +4918,7 @@
  Expr  : Node_Id := N;
  Low   : Node_Id;
  High  : Node_Id;
+ Csiz  : Uint;
  Remainder : Uint;
  Value : Uint;
  Nunits: Nat;
@@ -4933,14 +4934,6 @@
return False;
 end if;
 
-if Present (Packed_Array_Impl_Type (Ctyp)) then
-   return False;
-end if;
-
-if Has_Atomic_Components (Ctyp) then
-   return False;
-end if;
-
 Index := First_Index (Ctyp);
 while Present (Index) loop
Get_Index_Bounds (Index, Low, High);
@@ -4964,6 +4957,11 @@
Expr := Expression (First (Component_Associations (Expr)));
 end loop;
 
+if Has_Atomic_Components (Ctyp) then
+   return False;
+end if;
+
+Csiz := Component_Size (Ctyp);
 Ctyp := Component_Type (Ctyp);
 
 if Is_Atomic_Or_VFA (Ctyp) then
@@ -4978,20 +4976,19 @@
 return False;
  end if;
 
- --  All elementary types are supported
+ --  Access types need to be dealt with specially
 
- if not Is_Elementary_Type (Ctyp) then
-return False;
- end if;
+ if Is_Access_Type (Ctyp) then
 
- --  However access types need to be dealt with specially
+--  Component_Size is not set by Layout_Type if the component
+--  type is an access type ???
 
- if Is_Access_Type (Ctyp) then
+Csiz := Esize (Ctyp);
 
 --  Fat pointers are rejected as they are not really elementary
 --  for the backend.
 
-if Esize (Ctyp) /= System_Address_Size then
+if Csiz /= System_Address_Size then
return False;
 end if;
 
@@ -5002,16 +4999,27 @@
 if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
return False;
 end if;
+
+ --  Scalar types are OK if their size is a multiple of Storage_Unit
+
+ elsif Is_Scalar_Type (Ctyp) then
+
+if Csiz mod System_Storage_Unit /= 0 then
+   return False;
+end if;
+
+ --  Composite types are rejected
+
+ else
+return False;
  end if;
 
  --  The expression needs to be analyzed if True is returned
 
  Analyze_And_Resolve (Expr, Ctyp);
 
- --  The back end uses the Esize as the precision of the type
+ Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
 
- Nunits := UI_To_Int (Esize (Ctyp)) / System_Storage_Unit;
-
  if Nunits = 1 then
 return True;
  end if;
Index: ../testsuite/gnat.dg/component_size.adb
===
--- ../testsuite/gnat.dg/component_size.adb (revision 0)
+++ 

[Ada] Missing error on illegal initialization item

[Pierre-Marie de Rodat]

This patch modifies the analysis of pragma Initializes to detect an illegal
null initialization item.


-- Source --


--  remote.ads

package Remote is
   Y : Integer := 0;
end Remote;

--  pack.ads

with Remote;

package Pack
   with SPARK_Mode,
Initializes => (null => Remote.Y)
is
   X : Integer := 0;
end Pack;


-- Compilation and output --


$ gcc -c pack.ads
pack.ads:5:25: initialization item must denote object or state

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

2017-12-15  Hristian Kirtchev  

* sem_prag.adb (Analyze_Initialization_Item): Remove the specialized
processing for a null initialization item. Such an item is always
illegal.

Index: sem_prag.adb
===
--- sem_prag.adb(revision 255692)
+++ sem_prag.adb(working copy)
@@ -2752,10 +2752,6 @@
   --  A list of all initialization items processed so far. This list is
   --  used to detect duplicate items.
 
-  Non_Null_Seen : Boolean := False;
-  Null_Seen : Boolean := False;
-  --  Flags used to check the legality of a null initialization list
-
   States_And_Objs : Elist_Id := No_Elist;
   --  A list of all abstract states and objects declared in the visible
   --  declarations of the related package. This list is used to detect the
@@ -2785,91 +2781,67 @@
  Item_Id : Entity_Id;
 
   begin
- --  Null initialization list
+ Analyze   (Item);
+ Resolve_State (Item);
 
- if Nkind (Item) = N_Null then
-if Null_Seen then
-   SPARK_Msg_N ("multiple null initializations not allowed", Item);
+ if Is_Entity_Name (Item) then
+Item_Id := Entity_Of (Item);
 
-elsif Non_Null_Seen then
-   SPARK_Msg_N
- ("cannot mix null and non-null initialization items", Item);
-else
-   Null_Seen := True;
-end if;
+if Present (Item_Id)
+  and then Ekind_In (Item_Id, E_Abstract_State,
+  E_Constant,
+  E_Variable)
+then
+   --  When the initialization item is undefined, it appears as
+   --  Any_Id. Do not continue with the analysis of the item.
 
- --  Initialization item
+   if Item_Id = Any_Id then
+  null;
 
- else
-Non_Null_Seen := True;
+   --  The state or variable must be declared in the visible
+   --  declarations of the package (SPARK RM 7.1.5(7)).
 
-if Null_Seen then
-   SPARK_Msg_N
- ("cannot mix null and non-null initialization items", Item);
-end if;
+   elsif not Contains (States_And_Objs, Item_Id) then
+  Error_Msg_Name_1 := Chars (Pack_Id);
+  SPARK_Msg_NE
+("initialization item & must appear in the visible "
+ & "declarations of package %", Item, Item_Id);
 
-Analyze   (Item);
-Resolve_State (Item);
+   --  Detect a duplicate use of the same initialization item
+   --  (SPARK RM 7.1.5(5)).
 
-if Is_Entity_Name (Item) then
-   Item_Id := Entity_Of (Item);
+   elsif Contains (Items_Seen, Item_Id) then
+  SPARK_Msg_N ("duplicate initialization item", Item);
 
-   if Present (Item_Id)
- and then Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
-   then
-  --  When the initialization item is undefined, it appears as
-  --  Any_Id. Do not continue with the analysis of the item.
+   --  The item is legal, add it to the list of processed states
+   --  and variables.
 
-  if Item_Id = Any_Id then
- null;
+   else
+  Append_New_Elmt (Item_Id, Items_Seen);
 
-  --  The state or variable must be declared in the visible
-  --  declarations of the package (SPARK RM 7.1.5(7)).
-
-  elsif not Contains (States_And_Objs, Item_Id) then
- Error_Msg_Name_1 := Chars (Pack_Id);
- SPARK_Msg_NE
-   ("initialization item & must appear in the visible "
-& "declarations of package %", Item, Item_Id);
-
-  --  Detect a duplicate use of the same initialization item
-  --  (SPARK RM 7.1.5(5)).
-
-  elsif Contains (Items_Seen, Item_Id) then
- SPARK_Msg_N 

[Ada] Spurious error and missing warning on static predicate

[Pierre-Marie de Rodat]

This patch handles properly a static predicate on a scalar type that
is trivially true. Previous to this patch the compiler rejected the
predicate on the incorrect grounds that it was not a static expression.

Compiling bad_days.ads must yield:

   bad_days.ads:4:34: warning: predicate is redundant (always True)

---
package Bad_Days is
 type Day is (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday);
 subtype Day_Bad is Day with 
 Static_Predicate => Day_Bad in Day;
end Bad_Days;

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

2017-12-15  Ed Schonberg  

* exp_ch4.adb (Expand_N_In): Do not replace a membership test on a
scalar type with a validity test when the membership appears in a
predicate expression, to prevent a spurious error when predicate is
specified static.
* sem_ch13.adb (Build_Predicate_Functions): Add warning if a static
predicate, after constant-folding, reduces to True and is this
redundant.
* par-ch4.adb: Typo fixes and minor reformattings.

Index: exp_ch4.adb
===
--- exp_ch4.adb (revision 255693)
+++ exp_ch4.adb (working copy)
@@ -6015,10 +6015,20 @@
   --  have a test in the generic that makes sense with some types
   --  and not with other types.
 
-  and then not In_Instance
+  --  Similarly, do not rewrite membership as a validity check if
+  --  within the predicate function for the type.
+
 then
-   Substitute_Valid_Check;
-   goto Leave;
+   if In_Instance
+ or else (Ekind (Current_Scope) = E_Function
+   and then Is_Predicate_Function (Current_Scope))
+   then
+  null;
+
+   else
+  Substitute_Valid_Check;
+  goto Leave;
+   end if;
 end if;
 
 --  If we have an explicit range, do a bit of optimization based on
Index: par-ch4.adb
===
--- par-ch4.adb (revision 255693)
+++ par-ch4.adb (working copy)
@@ -645,8 +645,8 @@
  --  case of a name which can be extended in the normal manner.
  --  This case is handled by LP_State_Name or LP_State_Expr.
 
- --  (Ada2020) : the expression can be a reduction_expression_
- --  psarameter, i.e. a box or  < Simple_Expression >
+ --  (Ada 2020): the expression can be a reduction_expression_
+ --  parameter, i.e. a box or < Simple_Expression >.
 
  --  Note: if and case expressions (without an extra level of
  --  parentheses) are permitted in this context).
@@ -679,7 +679,7 @@
  end if;
 
  --  Here we have an expression after all, which may be a reduction
- --  expression with a binary operator
+ --  expression with a binary operator.
 
  if Token = Tok_Less then
 Scan; -- past <
@@ -2894,7 +2894,7 @@
Node1 := P_Name;
return Node1;
 
---  Ada2020: reduction expression parameter
+--  Ada 2020: reduction expression parameter
 
 when Tok_Less =>
Scan; -- past <
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 255678)
+++ sem_ch13.adb(working copy)
@@ -11919,6 +11919,12 @@
   then
  return True;
 
+  elsif Is_Entity_Name (Expr)
+and then Entity (Expr) = Standard_True
+  then
+ Error_Msg_N ("predicate is redundant (always True)?", Expr);
+ return True;
+
   --  That's an exhaustive list of tests, all other cases are not
   --  predicate-static, so we return False.
 
Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 255693)
+++ sem_ch4.adb (working copy)
@@ -4155,7 +4155,7 @@
   and then Parent (Loop_Par) /= N
 then
--  The parser cannot distinguish between a loop specification
-   --  and an iterator specification. If after pre-analysis the
+   --  and an iterator specification. If after preanalysis the
--  proper form has been recognized, rewrite the expression to
--  reflect the right kind. This is needed for proper ASIS
--  navigation. If expansion is enabled, the transformation is
@@ -4378,7 +4378,7 @@
   and then Parent (Loop_Par) /= N
 then
--  The parser cannot distinguish between a loop specification
-   --  and an iterator specification. If after pre-analysis the
+   --  and an iterator specification. If after preanalysis the
--  proper form has been 

[Ada] Concurrent types in pragma Initializes

[Pierre-Marie de Rodat]

Concurrent types and single concurrent types can now appear in the input list
of pragma Initializes as long as the type encloses the pragma.

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

gcc/ada/

2017-12-15  Hristian Kirtchev  

* sem_prag.adb (Analyze_Input_Item): Allow concurrent types to appear
within the input list of Initializes. Remove the uses of Input_OK.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  

* gnat.dg/initializes.ads, gnat.dg/initializes.adb: New testcase.
Index: sem_prag.adb
===
--- sem_prag.adb(revision 255693)
+++ sem_prag.adb(working copy)
@@ -2867,7 +2867,6 @@
 
  procedure Analyze_Input_Item (Input : Node_Id) is
 Input_Id : Entity_Id;
-Input_OK : Boolean := True;
 
  begin
 --  Null input list
@@ -2908,6 +2907,8 @@
  E_In_Parameter,
  E_In_Out_Parameter,
  E_Out_Parameter,
+ E_Protected_Type,
+ E_Task_Type,
  E_Variable)
   then
  --  The input cannot denote states or objects declared
@@ -2933,11 +2934,11 @@
null;
 
 else
-   Input_OK := False;
Error_Msg_Name_1 := Chars (Pack_Id);
SPARK_Msg_NE
  ("input item & cannot denote a visible object or "
   & "state of package %", Input, Input_Id);
+   return;
 end if;
  end if;
 
@@ -2945,26 +2946,25 @@
  --  (SPARK RM 7.1.5(5)).
 
  if Contains (Inputs_Seen, Input_Id) then
-Input_OK := False;
 SPARK_Msg_N ("duplicate input item", Input);
+return;
  end if;
 
- --  Input is legal, add it to the list of processed inputs
+ --  At this point it is known that the input is legal. Add
+ --  it to the list of processed inputs.
 
- if Input_OK then
-Append_New_Elmt (Input_Id, Inputs_Seen);
+ Append_New_Elmt (Input_Id, Inputs_Seen);
 
-if Ekind (Input_Id) = E_Abstract_State then
-   Append_New_Elmt (Input_Id, States_Seen);
-end if;
+ if Ekind (Input_Id) = E_Abstract_State then
+Append_New_Elmt (Input_Id, States_Seen);
+ end if;
 
-if Ekind_In (Input_Id, E_Abstract_State,
-   E_Constant,
-   E_Variable)
-  and then Present (Encapsulating_State (Input_Id))
-then
-   Append_New_Elmt (Input_Id, Constits_Seen);
-end if;
+ if Ekind_In (Input_Id, E_Abstract_State,
+E_Constant,
+E_Variable)
+   and then Present (Encapsulating_State (Input_Id))
+ then
+Append_New_Elmt (Input_Id, Constits_Seen);
  end if;
 
   --  The input references something that is not a state or an
Index: ../testsuite/gnat.dg/initializes.adb
===
--- ../testsuite/gnat.dg/initializes.adb(revision 0)
+++ ../testsuite/gnat.dg/initializes.adb(revision 0)
@@ -0,0 +1,33 @@
+--  { dg-do compile }
+
+package body Initializes is
+   protected body PO is
+  procedure Proc is
+ package Inner with Initializes => (Y => PO) is  --  OK
+Y : Boolean := X;
+ end Inner;
+
+ procedure Nested with Global => PO is   --  OK
+ begin
+null;
+ end Nested;
+  begin
+ Nested;
+  end Proc;
+   end PO;
+
+   protected body PT is
+  procedure Proc is
+ package Inner with Initializes => (Y => PT) is  --  OK
+Y : Boolean := X;
+ end Inner;
+
+ procedure Nested with Global => PT is   --  OK
+ begin
+null;
+ end Nested;
+  begin
+ Nested;
+  end Proc;
+   end PT;
+end Initializes;
Index: ../testsuite/gnat.dg/initializes.ads

[Ada] Spurious 'W' ALI line due to implicit with clause

[Pierre-Marie de Rodat]

This patch "fixes" an issue where an implicit with clause generated to emulate
an implicit Elaborate[_All] pragma appears on a 'W' line in the ALI file. As a
result, the 'W' line may introduce a spurious build dependency in GPRbuild.


-- Source --


--  func.ads

function Func return Boolean;

--  func.adb

function Func return Boolean is begin return True; end Func;

--  gen.ads

generic
package Gen is
   procedure Force_Body;
end Gen;

--  gen.adb

with Func;

package body Gen is
   Val : constant Boolean := Func;

   procedure Force_Body is begin null; end Force_Body;
end Gen;

--  pack.ads

with Gen;

package Pack is
   package Inst is new Gen;
end Pack;

--  main.adb

with Pack;

procedure Main is begin null; end Main;


-- Compilation and output --


$ gnatmake -q main.adb
$ grep -c "Z func" pack.ali
1

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

2017-12-15  Hristian Kirtchev  

* sem_elab.adb (Ensure_Prior_Elaboration_Static): Mark the generated
with clause as being implicit for an instantiation in order to
circumvent an issue with 'W' and 'Z' line encodings in ALI files.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 255683)
+++ sem_elab.adb(working copy)
@@ -3585,6 +3585,16 @@
  Set_Implicit_With (Clause);
  Set_Library_Unit  (Clause, Unit_Cunit);
 
+ --  The following is a kludge to satisfy a GPRbuild requirement. In
+ --  general, internal with clauses should be encoded on a 'Z' line in
+ --  ALI files, but due to an old bug, they are encoded as source with
+ --  clauses on a 'W' line. As a result, these "semi-implicit" clauses
+ --  introduce spurious build dependencies in GPRbuild. The only way to
+ --  eliminate this effect is to mark the implicit clauses as generated
+ --  for an instantiation.
+
+ Set_Implicit_With_From_Instantiation (Clause);
+
  Append_To (Items, Clause);
   end if;
 

[Ada] Spurious error on equality operator on incomplete type

[Pierre-Marie de Rodat]

This patch fixes a spurious error on a declaration for an equality
operator whose operands have an incomplete type, when the same declarative
oart includes another such equality operator on another incomplete type which
is used as an actual in an earlier instantiation.

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

gcc/ada/

2017-12-15  Ed Schonberg  

* sem_ch6.adb (Conformking_Types): Two incomplete types are conforming
when one of them is used as a generic actual, but only within an
instantiation.
* einfo.ads: Clarify use of flag Used_As_Generic_Actual.

gcc/testsuite/

2017-12-15  Ed Schonberg  

* gnat.dg/incomplete6.adb, gnat.dg/incomplete6.ads
Index: einfo.ads
===
--- einfo.ads   (revision 255690)
+++ einfo.ads   (working copy)
@@ -4583,7 +4583,9 @@
 
 --Used_As_Generic_Actual (Flag222)
 --   Defined in all entities, set if the entity is used as an argument to
---   a generic instantiation. Used to tune certain warning messages.
+--   a generic instantiation. Used to tune certain warning messages, and
+--   in checking type conformance within an instantiation that involves
+--   incomplete formal and actual types.
 
 --Uses_Lock_Free (Flag188)
 --   Defined in protected type entities. Set to True when the Lock Free
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 255693)
+++ sem_ch6.adb (working copy)
@@ -7666,10 +7666,12 @@
  return True;
 
   --  In Ada 2012, incomplete types (including limited views) can appear
-  --  as actuals in instantiations.
+  --  as actuals in instantiations, where they are conformant to the
+  --  corresponding incomplete formal.
 
   elsif Is_Incomplete_Type (Type_1)
 and then Is_Incomplete_Type (Type_2)
+and then In_Instance
 and then (Used_As_Generic_Actual (Type_1)
or else Used_As_Generic_Actual (Type_2))
   then
Index: ../testsuite/gnat.dg/incomplete6.adb
===
--- ../testsuite/gnat.dg/incomplete6.adb(revision 0)
+++ ../testsuite/gnat.dg/incomplete6.adb(revision 0)
@@ -0,0 +1,15 @@
+--  { dg-do compile }
+
+package body Incomplete6 is
+
+   function "=" (Left, Right : Vint) return Boolean is
+   begin
+  return Left.Value = Right.Value;
+   end;
+   
+   function "=" (Left, Right : Vfloat) return Boolean is
+   begin
+  return Left.Value = Right.Value;
+   end;
+
+end;
Index: ../testsuite/gnat.dg/incomplete6.ads
===
--- ../testsuite/gnat.dg/incomplete6.ads(revision 0)
+++ ../testsuite/gnat.dg/incomplete6.ads(revision 0)
@@ -0,0 +1,22 @@
+with Ada.Unchecked_Conversion;
+
+package Incomplete6 is
+   
+   type Vint;
+   function "=" (Left, Right : Vint) return Boolean;
+
+   type Vint is record
+  Value : Integer;
+   end record;
+
+   function To_Integer is new 
+ Ada.Unchecked_Conversion(Source => Vint, Target => Integer);
+   
+   type Vfloat;
+   function "=" (Left, Right : in Vfloat) return Boolean;
+
+   type Vfloat is record
+  Value : Float;
+   end record;
+
+end;

[Ada] Spurious alias error on access to array indexed by non-standard enum

[Pierre-Marie de Rodat]

This patch prevents the propagation of spurious errors about the prefix of
access being non-aliased when getting the access to an array indexed by an
enumeration with a custom representation.

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

gcc/ada/

2017-12-15  Justin Squirek  

* sem_attr.adb (Resolve_Attribute): Modify check for aliased view on
prefix to use the prefix's original node to avoid looking at expanded
conversions for certain array types.

gcc/testsuite/

2017-12-15  Justin Squirek  

* gnat.dg/aliasing4.adb: New testcase.
Index: sem_attr.adb
===
--- sem_attr.adb(revision 255678)
+++ sem_attr.adb(working copy)
@@ -1,7 +1,7 @@
   and then not (Nkind (P) = N_Selected_Component
  and then
Is_Overloadable (Entity (Selector_Name (P
-  and then not Is_Aliased_View (P)
+  and then not Is_Aliased_View (Original_Node (P))
   and then not In_Instance
   and then not In_Inlined_Body
   and then Comes_From_Source (N)

[Ada] Added warning on membership tests

[Pierre-Marie de Rodat]

RM 4.5.3 (28) specifies that (except for records and limited types) a
membership operation uses the predefined equality, regardless of whether
user-defined equality for the type is available. This can be confusing
and deserves a new warning.

Compiling code.adb must yield:

  code.adb:19:42: warning: membership test on "Var" uses predefined equality
  code.adb:19:42: warning: even if user-defined equality exists
  (RM 4.5.2 (28.1/3)

--
with Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
procedure Code is
   type Var is new Character;

   function "=" (C1, C2 : Var) return Boolean;

   function "=" (C1, C2 : Var) return Boolean is
  use Ada.Characters.Handling;
   begin
  return To_Lower (Character (C1)) = To_Lower (Character (C2));
   end "=";

   V : Var := 'A';

begin
   Put_Line ("equal " & Boolean'Image (V = 'a'));

   Put_Line ("in" & Boolean'Image (V in 'a' | 'o'));
end Code;

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

2017-12-15  Ed Schonberg  

* sem_res.adb (Resolve_Membership_Op): Add warning on a membership
operation on a scalar type for which there is a user-defined equality
operator.

Index: sem_res.adb
===
--- sem_res.adb (revision 255694)
+++ sem_res.adb (working copy)
@@ -9086,6 +9086,21 @@
end loop;
 end;
  end if;
+
+ --  RM 4.5.2 (28.1/3) specifies that for types other than records or
+ --  limited types, evaluation of a membership test uses the predefined
+ --  equality for the type. This may be confusing to users, and the
+ --  following warning appears useful for the most common case.
+
+ if Is_Scalar_Type (Ltyp)
+   and then Present (Get_User_Defined_Eq (Ltyp))
+ then
+Error_Msg_NE
+  ("membership test on& uses predefined equality?", N, Ltyp);
+Error_Msg_N
+  ("\even if user-defined equality exists (RM 4.5.2 (28.1/3)?", N);
+ end if;
+
   end Resolve_Set_Membership;
 
--  Start of processing for Resolve_Membership_Op

[Ada] Fix inconsistent usage of Machine in s-fatgen.adb

[Pierre-Marie de Rodat]

System.Fat_Gen is a generic unit implementing support routines for floating-
point attributes, for example the 'Machine attribute.  These routines make
themselves use of the 'Machine attribute, some of them by calling the
Machine support routine directly, some others by using the attribute.

Consistency dictates that a single idiom be used and the latter is to be
preferred, since it generates better code for targets without excessive
precision issues, i.e. all of them except for x86 and x86-64.

No functional changes.

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

2017-12-15  Eric Botcazou  

* exp_attr.adb (Is_Inline_Floating_Point_Attribute): Fix comment.
* libgnat/s-fatgen.adb (Model): Use Machine attribute.
(Truncation): Likewise.

Index: libgnat/s-fatgen.adb
===
--- libgnat/s-fatgen.adb(revision 255678)
+++ libgnat/s-fatgen.adb(working copy)
@@ -394,7 +394,7 @@
 
function Model (X : T) return T is
begin
-  return Machine (X);
+  return T'Machine (X);
end Model;
 
--
@@ -739,10 +739,11 @@
   Result := abs X;
 
   if Result >= Radix_To_M_Minus_1 then
- return Machine (X);
+ return T'Machine (X);
 
   else
- Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1;
+ Result :=
+   T'Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1;
 
  if Result > abs X then
 Result := Result - 1.0;
Index: exp_attr.adb
===
--- exp_attr.adb(revision 255678)
+++ exp_attr.adb(working copy)
@@ -8274,7 +8274,7 @@
--  Start of processing for Is_Inline_Floating_Point_Attribute
 
begin
-  --  Machine and Model can be expanded by the GCC and AAMP back ends only
+  --  Machine and Model can be expanded by the GCC back end only
 
   if Id = Attribute_Machine or else Id = Attribute_Model then
  return Is_GCC_Target;

[Ada] Spurious warning on default initialized object

[Pierre-Marie de Rodat]

This patch updates the implications that pragma Default_Initial_Condition has
on full default initialization of objects and types. According to the SPARK RM,
the pragma may appear without an expression

   7.3.3 The aspect_definition may be omitted; this is semantically equivalent
 to specifying a static Boolean_expression having the value True.

which also satisfies the notion of "full default initialization" in SPARK

   3.1   A type is said to define full default initialization if it is

* a private type whose Default_Initial_Condition aspect is
  specified to be a Boolean_expression.

The end result is that an object is now considered fully default initialized
for warning purposes. Prior to this patch, the compiler would warn on a read
of an object when

   * The object has default initialization
   * The object type carries pragma Default_Initial_Condition without an
 expression
   * No value is provided in between the object declaration and read

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

gcc/ada/

2017-12-15  Hristian Kirtchev  

* exp_util.adb (Add_Own_DIC): Ensure that the expression of the pragma
is available (Is_Verifiable_DIC_Pragma): Moved from Sem_Util.
* sem_util.adb (Has_Full_Default_Initialization):
Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
whether a type has full default initialization due to pragma
Default_Initial_Condition.
(Has_Fully_Default_Initializing_DIC_Pragma): New routine.
(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
* sem_util.ads (Has_Fully_Default_Initializing_DIC_Pragma): New
routine.
(Is_Verifiable_DIC_Pragma): Moved to Exp_Util.
* sem_warn.adb (Is_OK_Fully_Initialized):
Has_Fully_Default_Initializing_DIC_Pragma is now used to determine
whether a type has full default initialization due to pragma
Default_Initial_Condition.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  

* gnat.dg/dflt_init_cond.adb, gnat.dg/dflt_init_cond_pkg.ads: New
testcase.
Index: exp_util.adb
===
--- exp_util.adb(revision 255683)
+++ exp_util.adb(working copy)
@@ -165,6 +165,10 @@
--  Force evaluation of bounds of a slice, which may be given by a range
--  or by a subtype indication with or without a constraint.
 
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
+   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
+   --  an assertion expression that should be verified at run time.
+
function Make_CW_Equivalent_Type
  (T : Entity_Id;
   E : Node_Id) return Entity_Id;
@@ -1500,6 +1504,7 @@
   --  Start of processing for Add_Own_DIC
 
   begin
+ pragma Assert (Present (DIC_Expr));
  Expr := New_Copy_Tree (DIC_Expr);
 
  --  Perform the following substitution:
@@ -1733,8 +1738,6 @@
  --  Produce an empty completing body in the following cases:
  --* Assertions are disabled
  --* The DIC Assertion_Policy is Ignore
- --* Pragma DIC appears without an argument
- --* Pragma DIC appears with argument "null"
 
  if No (Stmts) then
 Stmts := New_List (Make_Null_Statement (Loc));
@@ -8715,6 +8718,21 @@
   and then Is_Itype (Full_Typ);
end Is_Untagged_Private_Derivation;
 
+   --
+   -- Is_Verifiable_DIC_Pragma --
+   --
+
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
+  Args : constant List_Id := Pragma_Argument_Associations (Prag);
+
+   begin
+  --  To qualify as verifiable, a DIC pragma must have a non-null argument
+
+  return
+Present (Args)
+  and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
+   end Is_Verifiable_DIC_Pragma;
+
---
-- Is_Volatile_Reference --
---
Index: sem_util.adb
===
--- sem_util.adb(revision 255680)
+++ sem_util.adb(working copy)
@@ -10384,19 +10384,16 @@
 
function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
   Comp : Entity_Id;
-  Prag : Node_Id;
 
begin
-  --  A type subject to pragma Default_Initial_Condition is fully default
-  --  initialized when the pragma appears with a non-null argument. Since
-  --  any type may act as the full view of a private type, this check must
-  --  be performed prior to the specialized tests below.
+  --  A type subject to pragma Default_Initial_Condition may be fully
+  --  default initialized depending on inheritance and the argument of
+  --  the pragma. Since any type may act as the full view of a private
+  

[Ada] Optimizing allocators for arrays with non-static upper bound

[Pierre-Marie de Rodat]

This patch extends the optimization of allocators for arrays of non-controlled
components, when the qualified expression for the aggregate has an
unconstrained type and the upper bound of the aggregte is non-static. In this
case it is safe to build the array in the allocated object, instead of first
creating a temporary for the aggregate, then allocating the object, and then
assigning the temporary to the object, as mandated by the dynamic semantics
of initialized allocators. This optimization is particularly useful when the
size of the aggregate may be too large to be built on the stack,

Executing the following:

   gnatmake -q foo
   ./foo

must yield:

   1000

---
with Text_IO; use Text_IO;
procedure Foo is

   type Record_Type is record
  I : Integer;
   end record;

   type Array_Type is array (Positive range <>) of Record_Type;
   type Array_Access is access all Array_Type;

   function Get_Last return Integer is
   begin
  return 10_000_000;
   end Get_Last;

   A : Array_Access := new Array_Type'(1 .. Get_Last => (I => 0));
begin
   Put_Line (Integer'Image (A'Length));
end Foo;

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

2017-12-15  Ed Schonberg  

* exp_aggr.adb (In_Place_Assign_OK): Extend the predicate to recognize
an array aggregate in an allocator, when the designated type is
unconstrained and the upper bound of the aggregate belongs to the base
type of the index.

Index: exp_aggr.adb
===
--- exp_aggr.adb(revision 255678)
+++ exp_aggr.adb(working copy)
@@ -5537,13 +5537,29 @@
Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
 
if not Compile_Time_Known_Value (Aggr_Lo)
- or else not Compile_Time_Known_Value (Aggr_Hi)
  or else not Compile_Time_Known_Value (Obj_Lo)
  or else not Compile_Time_Known_Value (Obj_Hi)
  or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
- or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
then
   return False;
+
+   --  For an assignment statement we require static matching
+   --  of bounds. Ditto for an allocator whose qualified
+   --  expression is a constrained type. If the expression in
+   --  the allocator is an unconstrained array, we accept an
+   --  upper bound that is not static, to allow for non-static
+   --  expressions of the base type. Clearly there are further
+   --  possibilities (with diminishing returns) for safely
+   --  building arrays in place here.
+
+   elsif Nkind (Parent (N)) = N_Assignment_Statement
+ or else Is_Constrained (Etype (Parent (N)))
+   then
+  if not Compile_Time_Known_Value (Aggr_Hi)
+   or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
+  then
+ return False;
+  end if;
end if;
 
Next_Index (Aggr_In);

[Ada] Ignore external calls from instances for elaboration

[Pierre-Marie de Rodat]

This patch restores the functionality of debug switch -gnatdL to the behavior
prior to revision 255412.  The existing behavior has been associated with
switch -gnatd_i.

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

gcc/ada/

2017-12-15  Hristian Kirtchev  

* debug.adb: Move the functionality of -gnatdL to -gnatd_i. Restore
the behavior of -gnatdL from before revision 255412.
* sem_elab.adb: Update the section of compiler switches.
(Build_Call_Marker): Do not create a marker for a call which originates
from an expanded spec or body of an instantiated gener, does not invoke
a generic formal subprogram, the target is external to the instance,
and -gnatdL is in effect.
(In_External_Context): New routine.
(Process_Conditional_ABE_Activation_Impl): Update the uses of -gnatdL
and associated flag.
(Process_Conditional_ABE_Call): Update the uses of -gnatdL and
associated flag.
* switch-c.adb (Scan_Front_End_Switches): Switch -gnatJ now sets switch
-gnatd_i.
* exp_unst.adb: Minor typo fixes and edits.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  

* gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase.
Index: checks.adb
===
--- checks.adb  (revision 255678)
+++ checks.adb  (working copy)
@@ -6819,7 +6819,7 @@
 
   if Nkind (N) /= N_Attribute_Reference
 and then (not Is_Entity_Name (N)
-or else Treat_As_Volatile (Entity (N)))
+   or else Treat_As_Volatile (Entity (N)))
   then
  Force_Evaluation (N, Mode => Strict);
   end if;
Index: debug.adb
===
--- debug.adb   (revision 255678)
+++ debug.adb   (working copy)
@@ -153,7 +153,7 @@
--  d_f
--  d_g
--  d_h
-   --  d_i
+   --  d_i  Ignore activations and calls to instances for elaboration
--  d_j
--  d_k
--  d_l
@@ -479,8 +479,8 @@
--   error messages are target dependent and irrelevant.
 
--  dL   The compiler ignores calls in instances and invoke subprograms
-   --   which are external to the instance for the static elaboration
-   --   model. This switch is orthogonal to d.G.
+   --   which are external to the instance for both the static and dynamic
+   --   elaboration models.
 
--  dM   Assume all variables have been modified, and ignore current value
--   indications. This debug flag disconnects the tracking of constant
@@ -734,8 +734,7 @@
--  d.G  Previously the compiler ignored calls via generic formal parameters
--   when doing the analysis for the static elaboration model. This is
--   now fixed, but we provide this debug flag to revert to the previous
-   --   situation of ignoring such calls to aid in transition. This switch
-   --   is orthogonal to dL.
+   --   situation of ignoring such calls to aid in transition.
 
--  d.H  Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
--   the call to gigi in ASIS_Mode.
@@ -832,6 +831,10 @@
--   control, conditional entry calls, timed entry calls, and requeue
--   statements in both the static and dynamic elaboration models.
 
+   --  d_i  The compiler ignores calls and task activations when they target a
+   --   subprogram or task type defined in an external instance for both
+   --   the static and dynamic elaboration models.
+
--  d_p  The compiler ignores calls to subprograms which verify the run-time
--   semantics of invariants and postconditions in both the static and
--   dynamic elaboration models.
Index: exp_ch6.adb
===
--- exp_ch6.adb (revision 255680)
+++ exp_ch6.adb (working copy)
@@ -5356,7 +5356,7 @@
 
  Else_Statements => New_List (
Make_Raise_Program_Error (Loc,
-  Reason => PE_All_Guards_Closed)));
+ Reason => PE_All_Guards_Closed)));
 
  --  If a separate initialization assignment was created
  --  earlier, append that following the assignment of the
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 255680)
+++ exp_ch7.adb (working copy)
@@ -4200,13 +4200,11 @@

 
procedure Expand_Cleanup_Actions (N : Node_Id) is
-  pragma Assert
-(Nkind_In (N,
-   N_Extended_Return_Statement,
-   N_Block_Statement,
-   N_Subprogram_Body,
-   N_Task_Body,
-   N_Entry_Body));
+  pragma Assert (Nkind_In (N, N_Block_Statement,
+  N_Entry_Body,
+

[Ada] Completing expression function need not trigger loading of package body

[Pierre-Marie de Rodat]

This patch prevents expression functions which complete previous declarations
in a package spec from loading the body of the package spec on the basis that
the expression function body is needed for inlining. This in turn prevents the
generation of spurious dependencies on units in ALI files.

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

gcc/ada/

2017-12-15  Hristian Kirtchev  

* inline.adb (Add_Inlined_Body): Do not add a function which is
completed by an expression function defined in the same context as the
initial declaration because the completing body is not in a package
body.
(Is_Non_Loading_Expression_Function): New routine.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  

* gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads,
gnat.dg/expr_func_pkg.adb: New testcase.
Index: inline.adb
===
--- inline.adb  (revision 255678)
+++ inline.adb  (working copy)
@@ -298,10 +298,65 @@
   --  Inline_Package means that the call is considered for inlining and
   --  its package compiled and scanned for more inlining opportunities.
 
+  function Is_Non_Loading_Expression_Function
+(Id : Entity_Id) return Boolean;
+  --  Determine whether arbitrary entity Id denotes a subprogram which is
+  --  either
+  --
+  --* An expression function
+  --
+  --* A function completed by an expression function where both the
+  --  spec and body are in the same context.
+
   function Must_Inline return Inline_Level_Type;
   --  Inlining is only done if the call statement N is in the main unit,
   --  or within the body of another inlined subprogram.
 
+  
+  -- Is_Non_Loading_Expression_Function --
+  
+
+  function Is_Non_Loading_Expression_Function
+(Id : Entity_Id) return Boolean
+  is
+ Body_Decl : Node_Id;
+ Body_Id   : Entity_Id;
+ Spec_Decl : Node_Id;
+
+  begin
+ --  A stand-alone expression function is transformed into a spec-body
+ --  pair in-place. Since both the spec and body are in the same list,
+ --  the inlining of such an expression function does not need to load
+ --  anything extra.
+
+ if Is_Expression_Function (Id) then
+return True;
+
+ --  A function may be completed by an expression function
+
+ elsif Ekind (Id) = E_Function then
+Spec_Decl := Unit_Declaration_Node (Id);
+
+if Nkind (Spec_Decl) = N_Subprogram_Declaration then
+   Body_Id := Corresponding_Body (Spec_Decl);
+
+   if Present (Body_Id) then
+  Body_Decl := Unit_Declaration_Node (Body_Id);
+
+  --  The inlining of a completing expression function does
+  --  not need to load anything extra when both the spec and
+  --  body are in the same context.
+
+  return
+Was_Expression_Function (Body_Decl)
+  and then Parent (Spec_Decl) = Parent (Body_Decl);
+   end if;
+end if;
+ end if;
+
+ return False;
+  end Is_Non_Loading_Expression_Function;
+
   -
   -- Must_Inline --
   -
@@ -415,10 +470,12 @@
  Set_Needs_Debug_Info (E, False);
   end if;
 
-  --  If the subprogram is an expression function, then there is no need to
-  --  load any package body since the body of the function is in the spec.
+  --  If the subprogram is an expression function, or is completed by one
+  --  where both the spec and body are in the same context, then there is
+  --  no need to load any package body since the body of the function is
+  --  in the spec.
 
-  if Is_Expression_Function (E) then
+  if Is_Non_Loading_Expression_Function (E) then
  Set_Is_Called (E);
  return;
   end if;
Index: ../testsuite/gnat.dg/expr_func_main.adb
===
--- ../testsuite/gnat.dg/expr_func_main.adb (revision 0)
+++ ../testsuite/gnat.dg/expr_func_main.adb (revision 0)
@@ -0,0 +1,9 @@
+--  { dg-do compile }
+
+with Expr_Func_Pkg; use Expr_Func_Pkg;
+
+procedure Expr_Func_Main is
+   Val : Boolean := Expr_Func (456);
+begin
+   null;
+end Expr_Func_Main;
Index: ../testsuite/gnat.dg/expr_func_pkg.adb
===
--- ../testsuite/gnat.dg/expr_func_pkg.adb  (revision 0)
+++ ../testsuite/gnat.dg/expr_func_pkg.adb  (revision 0)
@@ -0,0 +1,7 @@
+package body Expr_Func_Pkg is
+   function Func (Val : Integer) return Boolean is
+   begin
+  Error;  --  { dg-error "\"Error\" is undefined" }
+  return 

[Ada] Compiler crash with -gnatd.1 (force unnesting of subprograms)

[Pierre-Marie de Rodat]

This patch fixes a crash in the compiler when enabling unnesting of subprograms
on a generic unit.

The following must compile quietly:

gcc -c -gnatg -gnatd.1 a-btgbso.adb

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

2017-12-15  Ed Schonberg  

* exp_unst.adb (Unnest_Subprograms): Nothing to do if the main unit is
a generic package body. Unnesting is only an issue when generating
code, and if the main unit is generic then nested instance bodies have
not been created and analyzed, and unnesting will crash in the absence
of those bodies,

Index: exp_unst.adb
===
--- exp_unst.adb(revision 255680)
+++ exp_unst.adb(working copy)
@@ -302,6 +302,16 @@
  return;
   end if;
 
+  --  If the main unit is a package body then we need to examine the spec
+  --  to determine whether the main unit is generic (the scope stack is not
+  --  present when this is called on the main unit).
+
+  if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
+and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
+  then
+ return;
+  end if;
+
   --  At least for now, do not unnest anything but main source unit
 
   if not In_Extended_Main_Source_Unit (Subp_Body) then
@@ -553,8 +563,8 @@
Ent := Entity (Name (N));
 
--  We are only interested in calls to subprograms nested
-   --  within Subp. Calls to Subp itself or to subprograms that
-   --  are outside the nested structure do not affect us.
+   --  within Subp. Calls to Subp itself or to subprograms
+   --  that are outside the nested structure do not affect us.
 
if Scope_Within (Ent, Subp) then
 
@@ -1653,7 +1663,6 @@
 if Present (STT.ARECnF)
   and then Nkind (CTJ.N) /= N_Attribute_Reference
 then
-
--  CTJ.N is a call to a subprogram which may require a pointer
--  to an activation record. The subprogram containing the call
--  is CTJ.From and the subprogram being called is CTJ.To, so we

[Ada] Reject certain constants as constituents

[Pierre-Marie de Rodat]

This patch updates the analysis of pragma Refined_State to reject constants
which are used as refinement constituents and are either

   * Part of the visible state of a package

   * Part of the hidden state of a package, and lack indicator Part_Of.


-- Source --


--  var.ads

package Var
  with SPARK_Mode,
   Initializes => Input
is
   Input : Integer := 0;
end Var;

--  pack.ads

with Var;

package Pack
  with SPARK_Mode,
   Abstract_State => State
is
   procedure Force_Body;

private
   Const_1 : constant Integer := Var.Input;
   Const_2 : constant Integer := 2 with Part_Of => State;

   Var_1 : Integer := 1;
   Var_2 : Integer := 2 with Part_Of => State;

   package Priv_Pack is
  Const_3 : constant Integer := Var.Input;
  Const_4 : constant Integer := 4 with Part_Of => State;

  Var_3 : Integer := 3;
  Var_4 : Integer := 4 with Part_Of => State;
   end Priv_Pack;
end Pack;

--  pack.adb

package body Pack
  with SPARK_Mode,
   Refined_State =>
 (State =>
   (Const_1, --  Error
Const_2, --  OK
Var_1,   --  Error
Var_2,   --  OK
Priv_Pack.Const_3,   --  Error
Priv_Pack.Const_4,   --  OK
Priv_Pack.Var_3, --  Error
Priv_Pack.Var_4, --  OK
Const_5, --  OK
Const_6, --  OK
Body_Pack.Const_7,   --  OK
Body_Pack.Const_8))  --  OK
is
   Const_5 : constant Integer := Var.Input;
   Const_6 : constant Integer := 6;

   package Body_Pack is
  Const_7 : constant Integer := Var.Input;
  Const_8 : constant Integer := 8;
   end Body_Pack;

   procedure Force_Body is begin null; end Force_Body;
end Pack;


-- Compilation and output --


$ gcc -c -gnatf pack.adb
pack.adb:5:13: cannot use "Const_1" in refinement, constituent is not a hidden
  state of package "Pack"
pack.adb:7:13: cannot use "Var_1" in refinement, constituent is not a hidden
  state of package "Pack"
pack.adb:9:22: cannot use "Const_3" in refinement, constituent is not a hidden
  state of package "Pack"
pack.adb:11:22: cannot use "Var_3" in refinement, constituent is not a hidden
  state of package "Pack"
pack.ads:13:04: indicator Part_Of is required in this context (SPARK RM
  7.2.6(2))
pack.ads:13:04: "Var_1" is declared in the private part of package "Pack"
pack.ads:20:07: indicator Part_Of is required in this context (SPARK RM
  7.2.6(2))
pack.ads:20:07: "Var_3" is declared in the private part of package "Pack"

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

2017-12-15  Hristian Kirtchev  

* sem_prag.adb (Match_Constituent): Do not quietly accept constants as
suitable constituents.
* exp_util.adb: Minor reformatting.

Index: exp_util.adb
===
--- exp_util.adb(revision 255683)
+++ exp_util.adb(working copy)
@@ -165,6 +165,10 @@
--  Force evaluation of bounds of a slice, which may be given by a range
--  or by a subtype indication with or without a constraint.
 
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
+   --  Determine whether pragma Default_Initial_Condition denoted by Prag has
+   --  an assertion expression that should be verified at run time.
+
function Make_CW_Equivalent_Type
  (T : Entity_Id;
   E : Node_Id) return Entity_Id;
@@ -1500,6 +1504,7 @@
   --  Start of processing for Add_Own_DIC
 
   begin
+ pragma Assert (Present (DIC_Expr));
  Expr := New_Copy_Tree (DIC_Expr);
 
  --  Perform the following substitution:
@@ -1733,8 +1738,6 @@
  --  Produce an empty completing body in the following cases:
  --* Assertions are disabled
  --* The DIC Assertion_Policy is Ignore
- --* Pragma DIC appears without an argument
- --* Pragma DIC appears with argument "null"
 
  if No (Stmts) then
 Stmts := New_List (Make_Null_Statement (Loc));
@@ -8715,6 +8718,21 @@
   and then Is_Itype (Full_Typ);
end Is_Untagged_Private_Derivation;
 
+   --
+   -- Is_Verifiable_DIC_Pragma --
+   --
+
+   function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
+  Args : constant List_Id := Pragma_Argument_Associations (Prag);
+
+   begin
+  -- 

[Ada] Crash on subprogram instantiation in nested package

[Pierre-Marie de Rodat]

This patch fixes a crash on a subpogram instance that appears within a package
that declares the actual type for the instance, when the corresponding type is
a private or incomplete formal type.

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

gcc/ada

2017-12-15  Ed Schonberg  

* sem_ch6.adb (Possible_Freeze): Do not set Delayed_Freeze on an
subprogram instantiation, now that the enclosing wrapper package
carries an explicit freeze node. THis prevents freeze nodes for the
subprogram for appearing in the wrong scope. This is relevant when the
generic subprogram has a private or incomplete formal type and the
instance appears within a package that declares the actual type for the
instantiation, and that type has itself a delayed freeze.

gcc/testsuite/

2017-12-15  Ed Schonberg  

* gnat.dg/subp_inst.adb, gnat.dg/subp_inst_pkg.adb,
gnat.dg/subp_inst_pkg.ads: New testcase.
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 255678)
+++ sem_ch6.adb (working copy)
@@ -5834,8 +5834,21 @@
   -
 
   procedure Possible_Freeze (T : Entity_Id) is
+ Scop : constant Entity_Id := Scope (Designator);
   begin
- if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
+ --  If the subprogram appears within a package instance (which
+ --  may be the wrapper package of a subprogram instance) the
+ --  freeze node for that package will freeze the subprogram at
+ --  the proper place, so do not emit a freeze node for the
+ --  subprogram, given that it may appear in the wrong scope.
+
+ if Ekind (Scop) = E_Package
+   and then not Comes_From_Source (Scop)
+   and then Is_Generic_Instance (Scop)
+ then
+null;
+
+ elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
 Set_Has_Delayed_Freeze (Designator);
 
  elsif Is_Access_Type (T)
Index: ../testsuite/gnat.dg/subp_inst.adb
===
--- ../testsuite/gnat.dg/subp_inst.adb  (revision 0)
+++ ../testsuite/gnat.dg/subp_inst.adb  (revision 0)
@@ -0,0 +1,26 @@
+--  { dg-do compile }
+with Subp_Inst_Pkg;
+procedure Subp_Inst is
+   procedure Test_Access_Image is
+  package Nested is
+ type T is private;
+
+ type T_General_Access is access all T;
+ type T_Access is access T;
+ function Image1 is new Subp_Inst_Pkg.Image (T, T_Access);
+ function Image2 is new Subp_Inst_Pkg.Image (T, T_General_Access);
+ function Image3 is new Subp_Inst_Pkg.T_Image (T);
+  private
+ type T is null record;
+  end Nested;
+
+  A : aliased Nested.T;
+  AG : aliased constant Nested.T_General_Access := A'Access;
+  AA : aliased constant Nested.T_Access := new Nested.T;
+   begin
+  null;
+   end Test_Access_Image;
+
+begin
+   Test_Access_Image;
+end Subp_Inst;
Index: ../testsuite/gnat.dg/subp_inst_pkg.adb
===
--- ../testsuite/gnat.dg/subp_inst_pkg.adb  (revision 0)
+++ ../testsuite/gnat.dg/subp_inst_pkg.adb  (revision 0)
@@ -0,0 +1,20 @@
+with Ada.Unchecked_Conversion;
+with System.Address_Image;
+package body Subp_Inst_Pkg is
+
+   function Image (Val : T_Access) return String is
+  function Convert is new Ada.Unchecked_Conversion
+ (T_Access, System.Address);
+   begin
+  return System.Address_Image (Convert (Val));
+   end Image;
+
+   function T_Image (Val : access T) return String is
+  type T_Access is access all T;
+  function Convert is new Ada.Unchecked_Conversion
+ (T_Access, System.Address);
+   begin
+  return System.Address_Image (Convert (Val));
+   end T_Image;
+
+end Subp_Inst_Pkg;
Index: ../testsuite/gnat.dg/subp_inst_pkg.ads
===
--- ../testsuite/gnat.dg/subp_inst_pkg.ads  (revision 0)
+++ ../testsuite/gnat.dg/subp_inst_pkg.ads  (revision 0)
@@ -0,0 +1,13 @@
+package Subp_Inst_Pkg is
+   pragma Pure;
+
+   generic
+  type T;
+  type T_Access is access T;
+   function Image (Val : T_Access) return String;
+
+   generic
+  type T;
+   function T_Image (Val : access T) return String;
+
+end Subp_Inst_Pkg;

[Ada] Verify Part_Of indicator in non-SPARK code

[Pierre-Marie de Rodat]

This patch modifies the analysis of Part_Of indicators to verify their
associated rules even when the indicator appears in non-SPARK code. This
prevents possible tamperings of Part_Of constituents of single concurrent
types outside of SPARK code.


-- Source --


--  pack.ads

pragma Profile (Ravenscar);
pragma Partition_Elaboration_Policy (Sequential);

package Pack with SPARK_Mode is
   protected PO is
   end PO;

   X : Boolean := True with Part_Of => PO;
end Pack;

--  pack.adb

package body Pack is
   protected body PO is
   end PO;
begin
   X := not X;   --  OK
end Pack;

--  flip.adb

pragma Profile (Ravenscar);
pragma Partition_Elaboration_Policy (Sequential);

with Pack; use Pack;

procedure Flip with SPARK_Mode => Off is
begin
   X := not X;   --  Error
end Flip;


-- Compilation and output --


$ gcc -c flip.adb
$ gcc -c pack.adb
flip.adb:8:04: reference to variable "X" cannot appear in this context
flip.adb:8:04: "X" is constituent of single protected type "PO"
flip.adb:8:13: reference to variable "X" cannot appear in this context
flip.adb:8:13: "X" is constituent of single protected type "PO"

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

2017-12-15  Hristian Kirtchev  

* sem_prag.adb (Analyze_Part_Of): The context-specific portion of the
analysis is now directed to several specialized routines.
(Check_Part_Of_Abstract_State): New routine.
(Check_Part_Of_Concurrent_Type): New routine. Reimplement the checks
involving the item, the single concurrent type, and their respective
contexts.
* sem_res.adb (Resolve_Entity_Name): Potential constituents of a single
concurrent type are now recorded regardless of the SPARK mode.
* sem_util.adb (Check_Part_Of_Reference): Split some of the tests in
individual predicates.  A Part_Of reference is legal when it appears
within the statement list of the object's immediately enclosing
package.
(Is_Enclosing_Package_Body): New routine.
(Is_Internal_Declaration_Or_Body): New routine.
(Is_Single_Declaration_Or_Body): New routine.
(Is_Single_Task_Pragma): New routine.

Index: sem_prag.adb
===
--- sem_prag.adb(revision 255685)
+++ sem_prag.adb(working copy)
@@ -3168,71 +3168,26 @@
   Encap_Id : out Entity_Id;
   Legal: out Boolean)
is
-  Encap_Typ   : Entity_Id;
-  Item_Decl   : Node_Id;
-  Pack_Id : Entity_Id;
-  Placement   : State_Space_Kind;
-  Parent_Unit : Entity_Id;
+  procedure Check_Part_Of_Abstract_State;
+  pragma Inline (Check_Part_Of_Abstract_State);
+  --  Verify the legality of indicator Part_Of when the encapsulator is an
+  --  abstract state.
 
-   begin
-  --  Assume that the indicator is illegal
+  procedure Check_Part_Of_Concurrent_Type;
+  pragma Inline (Check_Part_Of_Concurrent_Type);
+  --  Verify the legality of indicator Part_Of when the encapsulator is a
+  --  single concurrent type.
 
-  Encap_Id := Empty;
-  Legal:= False;
+  --
+  -- Check_Part_Of_Abstract_State --
+  --
 
-  if Nkind_In (Encap, N_Expanded_Name,
-  N_Identifier,
-  N_Selected_Component)
-  then
- Analyze   (Encap);
- Resolve_State (Encap);
+  procedure Check_Part_Of_Abstract_State is
+ Pack_Id : Entity_Id;
+ Placement   : State_Space_Kind;
+ Parent_Unit : Entity_Id;
 
- Encap_Id := Entity (Encap);
-
- --  The encapsulator is an abstract state
-
- if Ekind (Encap_Id) = E_Abstract_State then
-null;
-
- --  The encapsulator is a single concurrent type (SPARK RM 9.3)
-
- elsif Is_Single_Concurrent_Object (Encap_Id) then
-null;
-
- --  Otherwise the encapsulator is not a legal choice
-
- else
-SPARK_Msg_N
-  ("indicator Part_Of must denote abstract state, single "
-   & "protected type or single task type", Encap);
-return;
- end if;
-
-  --  This is a syntax error, always report
-
-  else
- Error_Msg_N
-   ("indicator Part_Of must denote abstract state, single protected "
-& "type or single task type", Encap);
- return;
-  end if;
-
-  --  Catch a case where indicator Part_Of denotes the abstract view of a
-  --  variable which appears as an abstract state (SPARK RM 10.1.2 2).
-
-  if From_Limited_With (Encap_Id)
-and then Present (Non_Limited_View (Encap_Id))
-and then Ekind 

[Ada] Crash on expression function and discriminant-dependent component

[Pierre-Marie de Rodat]

This patch fixes a crash on an expression function that is a completion, when
the return expression includes a reference to a discriminant-dependent
component. An expression function that is a completion freezes all types
referenced in the expression, but some itypes are excluded because they are
frozen elsewhere (in the case pf discriminant-dependent component, when the
type itself is frozen).

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

gcc/ada/

2017-12-15  Ed Schonberg  

* sem_ch6.adb (Freeze_Expr_Types): Do not emit a freeze node for
an itype that is the type of a discriminant-dependent component.

Fixes QC04-017.

gcc/testsuite/

2017-12-15  Ed Schonberg  

* gnat.dg/expr_func2.ads, gnat.dg/expr_func2.adb: New testcase.
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 255683)
+++ sem_ch6.adb (working copy)
@@ -366,10 +366,13 @@
 
 procedure Check_And_Freeze_Type (Typ : Entity_Id) is
 begin
-   --  Skip Itypes created by the preanalysis
+   --  Skip Itypes created by the preanalysis, and itypes
+   --  whose scope is another type (i.e. component subtypes
+   --  that depend on a discriminant),
 
if Is_Itype (Typ)
- and then Scope_Within_Or_Same (Scope (Typ), Def_Id)
+ and then (Scope_Within_Or_Same (Scope (Typ), Def_Id)
+   or else Is_Type (Scope (Typ)))
then
   return;
end if;
Index: ../testsuite/gnat.dg/expr_func2.ads
===
--- ../testsuite/gnat.dg/expr_func2.ads (revision 0)
+++ ../testsuite/gnat.dg/expr_func2.ads (revision 0)
@@ -0,0 +1,22 @@
+package Expr_Func2 is
+
+   type T_Index is range 1 .. 255;
+
+   type T_Table is array (T_Index range <>) of Boolean;
+
+   type T_Variable_Table (N : T_Index := T_Index'First) is record
+  Table : T_Table (1 .. N);
+   end record;
+
+   type T_A_Variable_Table is access T_Variable_Table;
+
+   function Element (A_Variable_Table : T_A_Variable_Table) return Boolean;
+
+private
+
+   function Element (A_Variable_Table : T_A_Variable_Table) return Boolean is
+ (A_Variable_Table.all.Table (1));
+
+   procedure Foo;
+
+end Expr_Func2;
Index: ../testsuite/gnat.dg/expr_func2.adb
===
--- ../testsuite/gnat.dg/expr_func2.adb (revision 0)
+++ ../testsuite/gnat.dg/expr_func2.adb (revision 0)
@@ -0,0 +1,5 @@
+--  { dg-do compile }
+
+package body Expr_Func2 is
+   procedure Foo is null;
+end Expr_Func2;

[Ada] Spurious error on System'To_Address in -gnatc mode

[Pierre-Marie de Rodat]

This patch fixes a bug where if an address clause specifies a call to
System'To_Address as the address, and the code is compiled with the
-gnatc switch, the compiler gives a spurious error message.

The following test should compile quietly with -gnatc:

gcc -c -gnatc counter.ads

with System;

package Counter is
   type Bar is
  record
 X : Integer;
 Y : Integer;
  end record;

   Null_Bar : constant Bar := (0, 0);

   Address : constant := 16#D000_#;

   Foo : Bar := Null_Bar;
   for Foo'Address use System'To_Address (Address);
end Counter;

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

2017-11-16  Bob Duff  

* sem_ch13.adb (Check_Expr_Constants): Avoid error message in case of
System'To_Address.

Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 254797)
+++ sem_ch13.adb(working copy)
@@ -9783,6 +9783,15 @@
then
   Check_At_Constant_Address (Prefix (Nod));
 
+   --  Normally, System'To_Address will have been transformed into
+   --  an Unchecked_Conversion, but in -gnatc mode, it will not,
+   --  and we don't want to give an error, because the whole point
+   --  of 'To_Address is that it is static.
+
+   elsif Attribute_Name (Nod) = Name_To_Address then
+  pragma Assert (Operating_Mode = Check_Semantics);
+  null;
+
else
   Check_Expr_Constants (Prefix (Nod));
   Check_List_Constants (Expressions (Nod));

[Ada] Handling of elaboration warnings

[Pierre-Marie de Rodat]

This patch modifies the elaboration warnings produced by the ABE mechanism to
depend on the status of flag Elab_Warnings. The flag is enabled by compilation
switch -gnatwl. This change allows for selective suppression of warnings, as
well as total suppression.

In order to preserve the behaviour of the ABE mmechanism with respect ot the
legacy ABE mechanism, elaboration warnings are now on by default.

-
-- Sources --
-

--  selective_2.ads

package Selective_2 is
   Var : Integer;

   generic
   procedure Gen;

   procedure Proc;

   task type Tsk is
  entry E;
   end Tsk;

   package Direct is
  procedure Force_Body;
   end Direct;
end Selective_2;

--  selective_2.adb

package body Selective_2 is
   function Elaborator return Boolean is
  pragma Warnings (Off);
  procedure Inst is new Gen; --  OK
  T : Tsk;   --  OK
  pragma Warnings (On);
   begin
  Proc;  --  Warn
  return True;
   end Elaborator;

   package body Direct is
  procedure Force_Body is begin null; end Force_Body;
  pragma Warnings (Off);
  procedure Inst is new Gen; --  OK
  T : Tsk;   --  OK
  pragma Warnings (On);
   begin
  Proc;  --  Warn
   end Direct;

   Indirect : constant Boolean := Elaborator;

   procedure Gen is begin null; end Gen;

   procedure Proc is begin null; end Proc;

   task body Tsk is
   begin
  accept E;
   end Tsk;

   pragma Warnings (Off);
begin
   Var := 1; --  OK
end Selective_2;


-- Compilation and output --


$ gcc -c selective_2.adb
selective_2.adb:8:07: warning: cannot call "Proc" before body seen
selective_2.adb:8:07: warning: Program_Error may be raised at run time
selective_2.adb:8:07: warning:   body of unit "Selective_2" elaborated
selective_2.adb:8:07: warning:   function "Elaborator" called at line 22
selective_2.adb:8:07: warning:   procedure "Proc" called at line 8
selective_2.adb:19:07: warning: cannot call "Proc" before body seen
selective_2.adb:19:07: warning: Program_Error will be raised at run time

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

2017-11-16  Hristian Kirtchev  

* opt.ads: Elaboration warnings are now on by default. Add a comment
explaining why this is needed.
* sem_ch9.adb (Analyze_Requeue): Preserve the status of elaboration
warnings.
* sem_ch12.adb (Analyze_Package_Instantiation): Preserve the status of
elaboration warnings.
(Analyze_Subprogram_Instantiation): Preserve the status of elaboration
warnings.
* sem_elab.adb: Update the structure of Call_Attributes and
Instantiation_Attributes.
(Build_Call_Marker): Propagate the status of elaboration warnings from
the call to the marker.
(Extract_Call_Attributes): Extract the status of elaboration warnings.
(Extract_Instantiation_Attributes): Extract the status of elaboration
warnings.
(Process_Conditional_ABE_Activation_Impl): Elaboration diagnostics are
now dependent on the status of elaboration warnings.
(Process_Conditional_ABE_Call_Ada): Elaboration diagnostics are now
dependent on the status of elaboration warnings.
(Process_Conditional_ABE_Instantiation_Ada): Elaboration diagnostics
are now dependent on the status of elaboration warnings.
(Process_Guaranteed_ABE_Activation_Impl): Remove pragma Unreferenced
for formal Call_Attrs. Elaboration diagnostics are now dependent on the
status of elaboration warnings.
(Process_Guaranteed_ABE_Call): Elaboration diagnostics are now
dependent on the status of elaboration warnings.
(Process_Guaranteed_ABE_Instantiation): Elaboration diagnostics are now
dependent on the status of elaboration warnings.
* sem_prag.adb (Analyze_Pragma): Remove the unjustified warning
concerning pragma Elaborate.
* sem_res.adb (Resolve_Call): Preserve the status of elaboration
warnings.
(Resolve_Entry_Call): Propagate flag Is_Elaboration_Warnings_OK_Node
from the procedure call to the entry call.
* sem_util.adb (Mark_Elaboration_Attributes): Add formal parameter
Warnings.
(Mark_Elaboration_Attributes_Node): Preserve the status of elaboration
warnings
* sem_util.ads (Mark_Elaboration_Attributes): Add formal parameter
Warnings. Update the comment on usage.
* sinfo.adb (Is_Dispatching_Call): Update to use Flag6.
(Is_Elaboration_Warnings_OK_Node): New routine.

[Ada] Disallow renamings declaring tagged primitives

[Pierre-Marie de Rodat]

This patch implements the following SPARK rules from SPARK RM 6.1.1(3):

   A subprogram_renaming_declaration shall not declare a primitive operation of
   a tagged type.


-- Source --


--  renamings.ads

package Renamings with SPARK_Mode is
   type T is tagged null record;

   procedure Null_Proc (Obj : in out T) is null;

   procedure Proc_1 (Obj : in out T);
   procedure Proc_2 (Obj : in out T);

   function Func_1 (Obj : T) return Integer;
   function Func_2 (Obj : T) return Integer;

   function Func_3 return T;
   function Func_4 return T;

   procedure Error_1 (Obj : in out T) renames Null_Proc; --  Error
   procedure Error_2 (Obj : in out T) renames Proc_1;--  Error
   function  Error_3 (Obj : T) return Integer renames Func_1;--  Error
   function  Error_4 return T renames Func_3;--  Error

   package Nested is
  procedure OK_1 (Obj : in out T) renames Null_Proc; --  OK
  procedure OK_2 (Obj : in out T) renames Proc_1;--  OK
  function  OK_3 (Obj : T) return Integer renames Func_1;--  OK
  function  OK_4 return T renames Func_3;--  OK
   end Nested;
end Renamings;

--  renamings.adb

package body Renamings with SPARK_Mode is
   procedure Proc_1 (Obj : in out T) is begin null; end Proc_1;

   procedure Proc_2 (Obj : in out T) renames Proc_1; --  OK

   function Func_1 (Obj : T) return Integer is
   begin
  return 0;
   end Func_1;

   function Func_2 (Obj : T) return Integer renames Func_1;  --  OK

   function Func_3 return T is
  Result : T;
   begin
  return Result;
   end Func_3;

   function Func_4 return T renames Func_3;  --  OK
end Renamings;


-- Compilation and output --


$ gcc -c renamings.adb
renamings.ads:15:39: subprogram renaming "Error_1" cannot declare primitive of
  type "T" (SPARK RM 6.1.1(3))
renamings.ads:16:39: subprogram renaming "Error_2" cannot declare primitive of
  type "T" (SPARK RM 6.1.1(3))
renamings.ads:17:47: subprogram renaming "Error_3" cannot declare primitive of
  type "T" (SPARK RM 6.1.1(3))
renamings.ads:18:31: subprogram renaming "Error_4" cannot declare primitive of
  type "T" (SPARK RM 6.1.1(3))

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

2017-11-16  Hristian Kirtchev  

* sem_ch8.adb (Analyze_Subprogram_Renaming): Ensure that a renaming
declaration does not define a primitive operation of a tagged type for
SPARK.
(Check_SPARK_Primitive_Operation): New routine.

Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 254797)
+++ sem_ch8.adb (working copy)
@@ -59,6 +59,7 @@
 with Sem_Dist; use Sem_Dist;
 with Sem_Elab; use Sem_Elab;
 with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Type; use Sem_Type;
@@ -1924,6 +1925,10 @@
   --have one. Otherwise the subtype of Sub's return profile must
   --exclude null.
 
+  procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id);
+  --  Ensure that a SPARK renaming denoted by its entity Subp_Id does not
+  --  declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)).
+
   procedure Freeze_Actual_Profile;
   --  In Ada 2012, enforce the freezing rule concerning formal incomplete
   --  types: a callable entity freezes its profile, unless it has an
@@ -2519,6 +2524,52 @@
  end if;
   end Check_Null_Exclusion;
 
+  -
+  -- Check_SPARK_Primitive_Operation --
+  -
+
+  procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is
+ Prag : constant Node_Id := SPARK_Pragma (Subp_Id);
+ Typ  : Entity_Id;
+
+  begin
+ --  Nothing to do when the subprogram appears within an instance
+
+ if In_Instance then
+return;
+
+ --  Nothing to do when the subprogram is not subject to SPARK_Mode On
+ --  because this check applies to SPARK code only.
+
+ elsif not (Present (Prag)
+ and then Get_SPARK_Mode_From_Annotation (Prag) = On)
+ then
+return;
+
+ --  Nothing to do when the subprogram is not a primitive operation
+
+ elsif not Is_Primitive (Subp_Id) then
+return;
+ end if;
+
+ Typ := Find_Dispatching_Type (Subp_Id);
+
+ --  Nothing to do when the subprogram is a primitive operation of an
+ --  untagged type.
+
+ if No (Typ) then
+return;
+ end if;
+
+ --  At this point a renaming declaration introduces a new primitive
+ --  operation for a tagged type.
+
+ Error_Msg_Node_2 := Typ;
+   

[Ada] Crash on early call region of SPARK subprogram body

[Pierre-Marie de Rodat]

This patch accounts for the case where the early call region of a subprogram
body declared in a package body spans into the empty corresponding spec due to
pragma Elaborate_Body.


-- Source --


--  gnat.adc

pragma SPARK_Mode (On);

--  pack.ads

package Pack with Elaborate_Body is
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   procedure Proc;

   procedure Elaborator is
   begin
  Proc;
   end Elaborator;

   procedure Proc is
   begin
  Put_Line ("Proc");
   end Proc;

begin
   Elaborator;
end Pack;

-
-- Compilation --
-

$ gcc -c pack.adb

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

2017-11-16  Hristian Kirtchev  

* sem_elab.adb (Include): Including a node which is also a compilation
unit terminates the search because there are no more lists to examine.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 254803)
+++ sem_elab.adb(working copy)
@@ -4245,7 +4245,7 @@
   procedure Include (N : Node_Id; Curr : in out Node_Id);
   pragma Inline (Include);
   --  Update the Curr and Start pointers to include arbitrary construct N
-  --  in the early call region.
+  --  in the early call region. This routine raises ECR_Found.
 
   function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
   pragma Inline (Is_OK_Preelaborable_Construct);
@@ -4559,7 +4559,24 @@
   procedure Include (N : Node_Id; Curr : in out Node_Id) is
   begin
  Start := N;
- Curr  := Prev (Start);
+
+ --  The input node is a compilation unit. This terminates the search
+ --  because there are no more lists to inspect and there are no more
+ --  enclosing constructs to climb up to. The transitions are:
+ --
+ --private declarations -> terminate
+ --visible declarations -> terminate
+ --statements   -> terminate
+ --declarations -> terminate
+
+ if Nkind (Parent (Start)) = N_Compilation_Unit then
+raise ECR_Found;
+
+ --  Otherwise the input node is still within some list
+
+ else
+Curr := Prev (Start);
+ end if;
   end Include;
 
   ---

[Ada] Fix more precise mode for parameter

[Pierre-Marie de Rodat]

CodePeer analysis of GNAT showed that a parameter was not read and
always set on all paths, making it an out rather than an in-out.
This was not detected by the compiler, because one path ends up
raising an exception, which is not taken into account in the simpler
analysis done in GNAT.

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

2017-11-16  Yannick Moy  

* sem_elab.adb (Include): Fix mode of parameter Curr to out.

Index: sem_elab.adb
===
--- sem_elab.adb(revision 254804)
+++ sem_elab.adb(working copy)
@@ -4242,7 +4242,7 @@
   --  Determine whether list List contains at least one suitable construct
   --  for inclusion into an early call region.
 
-  procedure Include (N : Node_Id; Curr : in out Node_Id);
+  procedure Include (N : Node_Id; Curr : out Node_Id);
   pragma Inline (Include);
   --  Update the Curr and Start pointers to include arbitrary construct N
   --  in the early call region. This routine raises ECR_Found.
@@ -4556,7 +4556,7 @@
   -- Include --
   -
 
-  procedure Include (N : Node_Id; Curr : in out Node_Id) is
+  procedure Include (N : Node_Id; Curr : out Node_Id) is
   begin
  Start := N;
 

[Ada] Disallow renamings declaring tagged primitives

[Pierre-Marie de Rodat]

This patch enables the check which ensures that a subprogram renaming does not
declare a primitive operation of a tagged type in instantiations.

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

2017-11-16  Hristian Kirtchev  

* sem_ch8.adb (Check_SPARK_Primitive_Operation): Enable the check in
instantiations.

Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 254804)
+++ sem_ch8.adb (working copy)
@@ -2533,16 +2533,11 @@
  Typ  : Entity_Id;
 
   begin
- --  Nothing to do when the subprogram appears within an instance
-
- if In_Instance then
-return;
-
  --  Nothing to do when the subprogram is not subject to SPARK_Mode On
  --  because this check applies to SPARK code only.
 
- elsif not (Present (Prag)
- and then Get_SPARK_Mode_From_Annotation (Prag) = On)
+ if not (Present (Prag)
+  and then Get_SPARK_Mode_From_Annotation (Prag) = On)
  then
 return;