[multiple changes]

2017-01-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Check_Nonoverridable_Aspects); Refine check
	for illegal inherited Implicit_Dereference aspects with renamed
	discriminants.

2017-01-20  Javier Miranda  <miranda@adacore.com>

	* debug.adb (switch d.6): do not avoid declaring unreferenced itypes.
	* nlists.ads (Lock_Lists, Unlock_Lists): New subprograms.
	* nlists.adb (Lock_Lists, Unlock_Lists): New subprograms.
	(Set_First, Set_Last, Set_List_Link, Set_Next, Set_Parent,
	Set_Prev, Tree_Read): Adding assertion.
	* atree.ads (Lock_Nodes, Unlock_Nodes): New subprograms.
	* atree.adb (Lock_Nodes, Unlock_Nodes): New subprograms.
	(Set_Analyzed, Set_Check_Actuals, Set_Comes_From_Source,
	Set_Ekind, Set_Error_Posted, Set_Has_Aspects,
	Set_Is_Ignored_Ghost_Node, Set_Original_Node, Set_Paren_Count,
	Set_Parent, Set_Sloc, Set_Nkind, Set_FieldNN, Set_NodeNN,
	Set_ListNN, Set_ElistNN, Set_NameN, Set_StrN, Set_UintNN,
	Set_UrealNN, Set_FlagNNN, Set_NodeN_With_Parent,
	Set_ListN_With_Parent): Adding assertion.

2017-01-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Process_Convention): Diagnose properly a pragma
	import that applies to several homograph subprograms. when one
	of them is declared by a subprogram body.

2017-01-20  Justin Squirek  <squirek@adacore.com>

	* exp_ch6.adb (Expand_Call): Remove optimization
	that nulls out calls to null procedures.

From-SVN: r244699

gcc/ada/ChangeLog

@@ -1,3 +1,37 @@
+2017-01-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Check_Nonoverridable_Aspects); Refine check
+	for illegal inherited Implicit_Dereference aspects with renamed
+	discriminants.
+
+2017-01-20  Javier Miranda  <miranda@adacore.com>
+
+	* debug.adb (switch d.6): do not avoid declaring unreferenced itypes.
+	* nlists.ads (Lock_Lists, Unlock_Lists): New subprograms.
+	* nlists.adb (Lock_Lists, Unlock_Lists): New subprograms.
+	(Set_First, Set_Last, Set_List_Link, Set_Next, Set_Parent,
+	Set_Prev, Tree_Read): Adding assertion.
+	* atree.ads (Lock_Nodes, Unlock_Nodes): New subprograms.
+	* atree.adb (Lock_Nodes, Unlock_Nodes): New subprograms.
+	(Set_Analyzed, Set_Check_Actuals, Set_Comes_From_Source,
+	Set_Ekind, Set_Error_Posted, Set_Has_Aspects,
+	Set_Is_Ignored_Ghost_Node, Set_Original_Node, Set_Paren_Count,
+	Set_Parent, Set_Sloc, Set_Nkind, Set_FieldNN, Set_NodeNN,
+	Set_ListNN, Set_ElistNN, Set_NameN, Set_StrN, Set_UintNN,
+	Set_UrealNN, Set_FlagNNN, Set_NodeN_With_Parent,
+	Set_ListN_With_Parent): Adding assertion.
+
+2017-01-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_prag.adb (Process_Convention): Diagnose properly a pragma
+	import that applies to several homograph subprograms. when one
+	of them is declared by a subprogram body.
+
+2017-01-20  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch6.adb (Expand_Call): Remove optimization
+	that nulls out calls to null procedures.
+
 2017-01-20  Yannick Moy  <moy@adacore.com>
 
 	* inline.adb (Expand_Inlined_Call): Keep more

gcc/ada/atree.ads

@@ -405,9 +405,18 @@ package Atree is
    --  Called before the back end is invoked to lock the nodes table
    --  Also called after Unlock to relock???
 
+   procedure Lock_Nodes;
+   --  Called to lock node modifications when assertions are enabled; without
+   --  assertions calling this subprogram has no effect. The initial state of
+   --  the lock is unlocked.
+
    procedure Unlock;
    --  Unlocks nodes table, in cases where the back end needs to modify it
 
+   procedure Unlock_Nodes;
+   --  Called to unlock entity modifications when assertions are enabled; if
+   --  assertions are not enabled calling this subprogram has no effect.
+
    procedure Tree_Read;
    --  Initializes internal tables from current tree file using the relevant
    --  Table.Tree_Read routines. Note that Initialize should not be called if

gcc/ada/debug.adb

@@ -160,7 +160,7 @@ package body Debug is
    --  d.3  Output debugging information from Exp_Unst
    --  d.4  Do not delete generated C file in case of errors
    --  d.5  Do not generate imported subprogram definitions in C code
-   --  d.6
+   --  d.6  Do not avoid declaring unreferenced itypes in C code
    --  d.7
    --  d.8
    --  d.9
@@ -777,6 +777,10 @@ package body Debug is
    --       This debug flag disables this generation when generating C code,
    --       assuming a proper #include will be used instead.
 
+   --  d.6  By default the C back-end avoids declaring itypes that are not
+   --       referenced by the generated C code. This debug flag restores the
+   --       output of all the itypes.
+
    ------------------------------------------
    -- Documentation for Binder Debug Flags --
    ------------------------------------------

gcc/ada/exp_ch6.adb

@@ -3920,16 +3920,13 @@ package body Exp_Ch6 is
 
       if Ekind_In (Subp, E_Function, E_Procedure) then
 
-         --  We perform two simple optimization on calls:
+         --  We perform a simple optimization on calls for To_Address by
-
+         --  replacing them with an unchecked conversion. Not only is this
-         --  a) replace calls to null procedures unconditionally;
+         --  efficient, but it also avoids order of elaboration problems when
-
+         --  address clauses are inlined (address expression elaborated at the
-         --  b) for To_Address, just do an unchecked conversion. Not only is
-         --  this efficient, but it also avoids order of elaboration problems
-         --  when address clauses are inlined (address expression elaborated
          --  at the wrong point).
 
-         --  We perform these optimization regardless of whether we are in the
+         --  We perform this optimization regardless of whether we are in the
          --  main unit or in a unit in the context of the main unit, to ensure
          --  that tree generated is the same in both cases, for CodePeer use.
 
@@ -3938,10 +3935,6 @@ package body Exp_Ch6 is
               Unchecked_Convert_To
                 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
             return;
-
-         elsif Is_Null_Procedure (Subp) then
-            Rewrite (Call_Node, Make_Null_Statement (Loc));
-            return;
          end if;
 
          --  Handle inlining. No action needed if the subprogram is not inlined

gcc/ada/nlists.adb

@@ -40,6 +40,10 @@ with Sinfo;  use Sinfo;
 with Table;
 
 package body Nlists is
+   Locked : Boolean := False;
+   --  Compiling with assertions enabled, list contents modifications are
+   --  permitted only when this switch is set to False; compiling without
+   --  assertions this lock has no effect.
 
    use Atree_Private_Part;
    --  Get access to Nodes table
@@ -727,6 +731,16 @@ package body Nlists is
       Next_Node.Release;
    end Lock;
 
+   ----------------
+   -- Lock_Lists --
+   ----------------
+
+   procedure Lock_Lists is
+   begin
+      pragma Assert (not Locked);
+      Locked := True;
+   end Lock_Lists;
+
    -------------------
    -- New_Copy_List --
    -------------------
@@ -1403,6 +1417,7 @@ package body Nlists is
 
    procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
    begin
+      pragma Assert (not Locked);
       Lists.Table (List).First := To;
    end Set_First;
 
@@ -1412,6 +1427,7 @@ package body Nlists is
 
    procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
    begin
+      pragma Assert (not Locked);
       Lists.Table (List).Last := To;
    end Set_Last;
 
@@ -1421,6 +1437,7 @@ package body Nlists is
 
    procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
    begin
+      pragma Assert (not Locked);
       Nodes.Table (Node).Link := Union_Id (To);
    end Set_List_Link;
 
@@ -1430,6 +1447,7 @@ package body Nlists is
 
    procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
    begin
+      pragma Assert (not Locked);
       Next_Node.Table (Node) := To;
    end Set_Next;
 
@@ -1439,6 +1457,7 @@ package body Nlists is
 
    procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
    begin
+      pragma Assert (not Locked);
       pragma Assert (List <= Lists.Last);
       Lists.Table (List).Parent := Node;
    end Set_Parent;
@@ -1449,6 +1468,7 @@ package body Nlists is
 
    procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
    begin
+      pragma Assert (not Locked);
       Prev_Node.Table (Node) := To;
    end Set_Prev;
 
@@ -1458,6 +1478,7 @@ package body Nlists is
 
    procedure Tree_Read is
    begin
+      pragma Assert (not Locked);
       Lists.Tree_Read;
       Next_Node.Tree_Read;
       Prev_Node.Tree_Read;
@@ -1485,4 +1506,14 @@ package body Nlists is
       Next_Node.Locked := False;
    end Unlock;
 
+   ------------------
+   -- Unlock_Lists --
+   ------------------
+
+   procedure Unlock_Lists is
+   begin
+      pragma Assert (Locked);
+      Locked := False;
+   end Unlock_Lists;
+
 end Nlists;

gcc/ada/nlists.ads

@@ -340,9 +340,18 @@ package Nlists is
    procedure Lock;
    --  Called to lock tables before back end is called
 
+   procedure Lock_Lists;
+   --  Called to lock list contents when assertions are enabled. Without
+   --  assertions calling this subprogram has no effect. The initial state
+   --  of the lock is unlocked.
+
    procedure Unlock;
    --  Unlock tables, in cases where the back end needs to modify them
 
+   procedure Unlock_Lists;
+   --  Called to unlock list contents when assertions are enabled; if
+   --  assertions are not enabled calling this subprogram has no effect.
+
    procedure Tree_Read;
    --  Initializes internal tables from current tree file using the relevant
    --  Table.Tree_Read routines. Note that Initialize should not be called if

gcc/ada/sem_ch3.adb

@@ -2781,44 +2781,48 @@ package body Sem_Ch3 is
       ----------------------------------
 
       procedure Check_Nonoverridable_Aspects is
-         Prev_Aspects   : constant List_Id :=
+         function Get_Aspect_Spec
-                            Aspect_Specifications (Parent (Def_Id));
+           (Specs       : List_Id;
-         Par_Type       : Entity_Id;
+            Aspect_Name : Name_Id) return Node_Id;
-
-         function Has_Aspect_Spec
-           (Specs : List_Id;
-            Aspect_Name : Name_Id) return Boolean;
          --  Check whether a list of aspect specifications includes an entry
          --  for a specific aspect. The list is either that of a partial or
          --  a full view.
 
          ---------------------
-         -- Has_Aspect_Spec --
+         -- Get_Aspect_Spec --
          ---------------------
 
-         function Has_Aspect_Spec
+         function Get_Aspect_Spec
-           (Specs : List_Id;
+           (Specs       : List_Id;
-            Aspect_Name : Name_Id) return Boolean
+            Aspect_Name : Name_Id) return Node_Id
          is
             Spec : Node_Id;
+
          begin
             Spec := First (Specs);
             while Present (Spec) loop
                if Chars (Identifier (Spec)) = Aspect_Name then
-                  return True;
+                  return Spec;
                end if;
                Next (Spec);
             end loop;
-            return False;
+
-         end Has_Aspect_Spec;
+            return Empty;
+         end Get_Aspect_Spec;
+
+         --  Local variables
+
+         Prev_Aspects   : constant List_Id :=
+                            Aspect_Specifications (Parent (Def_Id));
+         Par_Type       : Entity_Id;
+         Prev_Aspect    : Node_Id;
 
       --  Start of processing for Check_Nonoverridable_Aspects
 
       begin
-
+         --  Get parent type of derived type. Note that Prev is the entity in
-         --  Get parent type of derived type. Note that Prev is the entity
+         --  the partial declaration, but its contents are now those of full
-         --  in the partial declaration, but its contents are now those of
+         --  view, while Def_Id reflects the partial view.
-         --  full view, while Def_Id reflects the partial view.
 
          if Is_Private_Type (Def_Id) then
             Par_Type := Etype (Full_View (Def_Id));
@@ -2834,10 +2838,13 @@ package body Sem_Ch3 is
            and then Present (Discriminant_Specifications (Parent (Prev)))
            and then Present (Get_Reference_Discriminant (Par_Type))
          then
-            if
+            Prev_Aspect :=
-              not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference)
+              Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference);
-                and then Present
+
-                  (Discriminant_Specifications (Original_Node (Parent (Prev))))
+            if No (Prev_Aspect)
+              and then Present
+                         (Discriminant_Specifications
+                           (Original_Node (Parent (Prev))))
             then
                Error_Msg_N
                  ("type does not inherit implicit dereference", Prev);
@@ -2847,14 +2854,28 @@ package body Sem_Ch3 is
                --  is consistent with that of the parent.
 
                declare
-                  Par_Discr : constant Entity_Id :=
+                  Par_Discr  : constant Entity_Id :=
                                 Get_Reference_Discriminant (Par_Type);
-                  Cur_Discr : constant Entity_Id :=
+                  Cur_Discr  : constant Entity_Id :=
                                 Get_Reference_Discriminant (Prev);
+
                begin
                   if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
                      Error_Msg_N ("aspect incosistent with that of parent", N);
                   end if;
+
+                  --  Check that specification in partial view matches the
+                  --  inherited aspect. Compare names directly because aspect
+                  --  expression may not be analyzed.
+
+                  if Present (Prev_Aspect)
+                    and then Nkind (Expression (Prev_Aspect)) = N_Identifier
+                    and then Chars (Expression (Prev_Aspect)) /=
+                               Chars (Cur_Discr)
+                  then
+                     Error_Msg_N
+                       ("aspect incosistent with that of parent", N);
+                  end if;
                end;
             end if;
          end if;
@@ -9666,9 +9687,8 @@ package body Sem_Ch3 is
                   null;
 
                elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
-                 and then
+                 and then Has_Per_Object_Constraint
-                   Has_Per_Object_Constraint
+                            (Defining_Identifier (Parent (Parent (Def))))
-                     (Defining_Identifier (Parent (Parent (Def))))
                then
                   null;
 
@@ -9688,7 +9708,7 @@ package body Sem_Ch3 is
 
             if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
               and then not Is_Class_Wide_Type
-                         (Designated_Type (Etype (Discr)))
+                             (Designated_Type (Etype (Discr)))
               and then Etype (Discr_Expr (J)) /= Any_Type
               and then Is_Class_Wide_Type
                          (Designated_Type (Etype (Discr_Expr (J))))
@@ -9702,7 +9722,7 @@ package body Sem_Ch3 is
             then
                Error_Msg_NE
                  ("constraint for discriminant& must be access to variable",
-                    Def, Discr);
+                  Def, Discr);
             end if;
          end if;
 

gcc/ada/sem_prag.adb

@@ -7633,6 +7633,17 @@ package body Sem_Prag is
                   goto Continue;
                end if;
 
+               if Is_Subprogram (E1)
+                 and then Nkind (Parent (Declaration_Node (E1))) =
+                            N_Subprogram_Body
+                 and then not Relaxed_RM_Semantics
+               then
+                  Set_Has_Completion (E);  --  to prevent cascaded error
+                  Error_Pragma_Ref
+                    ("pragma% requires separate spec and must come before "
+                     & "body#", E1);
+               end if;
+
                --  Do not set the pragma on inherited operations or on formal
                --  subprograms.