[multiple changes]

2017-04-27  Yannick Moy  <moy@adacore.com>

	* sem_res.adb: Remove duplicate code.
	* sem_attr.adb: Delete duplicate code.

2017-04-27  Bob Duff  <duff@adacore.com>

	* g-dyntab.adb: Reduce the amount of copying in
	Release. No need to copy items past Last.

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb Add with and use clauses for Sem_Disp.
	(Install_Primitive_Elaboration_Check): New routine.
	* checks.ads (Install_Primitive_Elaboration_Check): New routine.
	* exp_attr.adb (Expand_N_Attribute_Reference): Clean up the
	processing of 'Elaborated.
	* exp_ch6.adb (Expand_N_Subprogram_Body): Install a primitive
	elaboration check.

From-SVN: r247330

gcc/ada/ChangeLog

+2017-04-27  Yannick Moy  <moy@adacore.com>
+
+	* sem_res.adb: Remove duplicate code.
+	* sem_attr.adb: Delete duplicate code.
+
+2017-04-27  Bob Duff  <duff@adacore.com>
+
+	* g-dyntab.adb: Reduce the amount of copying in
+	Release. No need to copy items past Last.
+
+2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* checks.adb Add with and use clauses for Sem_Disp.
+	(Install_Primitive_Elaboration_Check): New routine.
+	* checks.ads (Install_Primitive_Elaboration_Check): New routine.
+	* exp_attr.adb (Expand_N_Attribute_Reference): Clean up the
+	processing of 'Elaborated.
+	* exp_ch6.adb (Expand_N_Subprogram_Body): Install a primitive
+	elaboration check.
+
 2017-04-27  Bob Duff  <duff@adacore.com>
 
 	* g-dyntab.ads, g-dyntab.adb, g-table.ads: Remove incorrect assertion.

gcc/ada/checks.adb

@@ -48,6 +48,7 @@ with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
@@ -7734,6 +7735,203 @@ package body Checks is
       Mark_Non_Null;
    end Install_Null_Excluding_Check;
 
+   -----------------------------------------
+   -- Install_Primitive_Elaboration_Check --
+   -----------------------------------------
+
+   procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is
+
+      function Within_Compilation_Unit_Instance
+        (Subp_Id : Entity_Id) return Boolean;
+      --  Determine whether subprogram Subp_Id appears within an instance which
+      --  acts as a compilation unit.
+
+      --------------------------------------
+      -- Within_Compilation_Unit_Instance --
+      --------------------------------------
+
+      function Within_Compilation_Unit_Instance
+        (Subp_Id : Entity_Id) return Boolean
+      is
+         Pack : Entity_Id;
+
+      begin
+         --  Examine the scope chain looking for a compilation-unit-level
+         --  instance.
+
+         Pack := Scope (Subp_Id);
+         while Present (Pack) and then Pack /= Standard_Standard loop
+            if Ekind (Pack) = E_Package
+              and then Is_Generic_Instance (Pack)
+              and then Nkind (Parent (Unit_Declaration_Node (Pack))) =
+                         N_Compilation_Unit
+            then
+               return True;
+            end if;
+
+            Pack := Scope (Pack);
+         end loop;
+
+         return False;
+      end Within_Compilation_Unit_Instance;
+
+      --  Local declarations
+
+      Context   : constant Node_Id    := Parent (Subp_Body);
+      Loc       : constant Source_Ptr := Sloc (Subp_Body);
+      Subp_Id   : constant Entity_Id  := Unique_Defining_Entity (Subp_Body);
+      Subp_Decl : constant Node_Id    := Unit_Declaration_Node (Subp_Id);
+
+      Decls   : List_Id;
+      Flag_Id : Entity_Id;
+      Set_Ins : Node_Id;
+      Tag_Typ : Entity_Id;
+
+   --  Start of processing for Install_Primitive_Elaboration_Check
+
+   begin
+      --  Do not generate an elaboration check in compilation modes where
+      --  expansion is not desirable.
+
+      if ASIS_Mode or GNATprove_Mode then
+         return;
+
+      --  Do not generate an elaboration check if the related subprogram is
+      --  not subjected to accessibility checks.
+
+      elsif Elaboration_Checks_Suppressed (Subp_Id) then
+         return;
+
+      --  Do not consider subprograms which act as compilation units, because
+      --  they cannot be the target of a dispatching call.
+
+      elsif Nkind (Context) = N_Compilation_Unit then
+         return;
+
+      --  Only nonabstract library-level source primitives are considered for
+      --  this check.
+
+      elsif not
+        (Comes_From_Source (Subp_Id)
+          and then Is_Library_Level_Entity (Subp_Id)
+          and then Is_Primitive (Subp_Id)
+          and then not Is_Abstract_Subprogram (Subp_Id))
+      then
+         return;
+
+      --  Do not consider inlined primitives, because once the body is inlined
+      --  the reference to the elaboration flag will be out of place and will
+      --  result in an undefined symbol.
+
+      elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then
+         return;
+
+      --  Do not generate a duplicate elaboration check. This happens only in
+      --  the case of primitives completed by an expression function, as the
+      --  corresponding body is apparently analyzed and expanded twice.
+
+      elsif Analyzed (Subp_Body) then
+         return;
+
+      --  Do not consider primitives which occur within an instance that acts
+      --  as a compilation unit. Such an instance defines its spec and body out
+      --  of order (body is first) within the tree, which causes the reference
+      --  to the elaboration flag to appear as an undefined symbol.
+
+      elsif Within_Compilation_Unit_Instance (Subp_Id) then
+         return;
+      end if;
+
+      Tag_Typ := Find_Dispatching_Type (Subp_Id);
+
+      --  Only tagged primitives may be the target of a dispatching call
+
+      if No (Tag_Typ) then
+         return;
+
+      --  Do not consider finalization-related primitives, because they may
+      --  need to be called while elaboration is taking place.
+
+      elsif Is_Controlled (Tag_Typ)
+        and then Nam_In (Chars (Subp_Id), Name_Adjust,
+                                          Name_Finalize,
+                                          Name_Initialize)
+      then
+         return;
+      end if;
+
+      --  Create the declaration of the elaboration flag. The name carries a
+      --  unique counter in case of name overloading.
+
+      Flag_Id :=
+        Make_Defining_Identifier (Loc,
+          Chars => New_External_Name (Chars (Subp_Id), 'F', -1));
+      Set_Is_Frozen (Flag_Id);
+
+      --  Insert the declaration of the elaboration flag in front of the
+      --  primitive spec and analyze it in the proper context.
+
+      Push_Scope (Scope (Subp_Id));
+
+      --  Generate:
+      --    F : Boolean := False;
+
+      Insert_Action (Subp_Decl,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Flag_Id,
+          Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
+          Expression          => New_Occurrence_Of (Standard_False, Loc)));
+      Pop_Scope;
+
+      --  Prevent the compiler from optimizing the elaboration check by killing
+      --  the current value of the flag and the associated assignment.
+
+      Set_Current_Value   (Flag_Id, Empty);
+      Set_Last_Assignment (Flag_Id, Empty);
+
+      --  Add a check at the top of the body declarations to ensure that the
+      --  elaboration flag has been set.
+
+      Decls := Declarations (Subp_Body);
+
+      if No (Decls) then
+         Decls := New_List;
+         Set_Declarations (Subp_Body, Decls);
+      end if;
+
+      --  Generate:
+      --    if not F then
+      --       raise Program_Error with "access before elaboration";
+      --    end if;
+
+      Prepend_To (Decls,
+        Make_Raise_Program_Error (Loc,
+          Condition =>
+            Make_Op_Not (Loc,
+              Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)),
+          Reason    => PE_Access_Before_Elaboration));
+
+      Analyze (First (Decls));
+
+      --  Set the elaboration flag once the body has been elaborated. Insert
+      --  the statement after the subprogram stub when the primitive body is
+      --  a subunit.
+
+      if Nkind (Context) = N_Subunit then
+         Set_Ins := Corresponding_Stub (Context);
+      else
+         Set_Ins := Subp_Body;
+      end if;
+
+      --  Generate:
+      --    F := True;
+
+      Insert_After_And_Analyze (Set_Ins,
+        Make_Assignment_Statement (Loc,
+          Name       => New_Occurrence_Of (Flag_Id, Loc),
+          Expression => New_Occurrence_Of (Standard_True, Loc)));
+   end Install_Primitive_Elaboration_Check;
+
    --------------------------
    -- Install_Static_Check --
    --------------------------

gcc/ada/checks.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -337,6 +337,12 @@ package Checks is
    --  Determines whether an access node requires a runtime access check and
    --  if so inserts the appropriate run-time check.
 
+   procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id);
+   --  Insert a check which ensures that subprogram body Subp_Body has been
+   --  properly elaborated. The check is installed only when Subp_Body is the
+   --  body of a nonabstract library-level primitive of a tagged type. Further
+   --  restrictions may apply, see the body for details.
+
    function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id;
    --  This function is used by top level overflow checking routines to do a
    --  mark/release operation on the secondary stack around bignum operations.

gcc/ada/exp_attr.adb

@@ -3025,16 +3025,15 @@ package body Exp_Attr is
       --  Note: The Elaborated attribute is never passed to the back end
 
       when Attribute_Elaborated => Elaborated : declare
-         Ent : constant Entity_Id := Entity (Pref);
+         Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
 
       begin
-         if Present (Elaboration_Entity (Ent)) then
+         if Present (Elab_Id) then
             Rewrite (N,
               Make_Op_Ne (Loc,
-                Left_Opnd =>
-                  New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
-                Right_Opnd =>
-                  Make_Integer_Literal (Loc, Uint_0)));
+                Left_Opnd  => New_Occurrence_Of (Elab_Id, Loc),
+                Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
+
             Analyze_And_Resolve (N, Typ);
          else
             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));

gcc/ada/exp_ch6.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -5632,6 +5632,13 @@ package body Exp_Ch6 is
       --  Set to encode entity names in package body before gigi is called
 
       Qualify_Entity_Names (N);
+
+      --  If the body belongs to a nonabstract library-level source primitive
+      --  of a tagged type, install an elaboration check which ensures that a
+      --  dispatching call targeting the primitive will not execute the body
+      --  without it being previously elaborated.
+
+      Install_Primitive_Elaboration_Check (N);
    end Expand_N_Subprogram_Body;
 
    -----------------------------------

gcc/ada/g-dyntab.adb

@@ -348,7 +348,7 @@ package body GNAT.Dynamic_Tables is
             New_Table : constant Alloc_Ptr := new Alloc_Type;
 
          begin
-            New_Table (Alloc_Type'Range) := Old_Table (Alloc_Type'Range);
+            New_Table (First .. Last (T)) := Old_Table (First .. Last (T));
             T.P.Last_Allocated := New_Last_Alloc;
             Free (Old_Table);
             T.Table := To_Table_Ptr (New_Table);

gcc/ada/sem_attr.adb

@@ -9662,9 +9662,6 @@ package body Sem_Attr is
          elsif Is_Access_Type (Typ) then
             Id := RE_Type_Class_Access;
 
-         elsif Is_Enumeration_Type (Typ) then
-            Id := RE_Type_Class_Enumeration;
-
          elsif Is_Task_Type (Typ) then
             Id := RE_Type_Class_Task;
 

gcc/ada/sem_res.adb

@@ -6797,12 +6797,6 @@ package body Sem_Res is
             return;
          end if;
 
-      --  For Standard.Wide_Wide_Character or a type derived from it, we
-      --  know the literal is in range, since the parser checked.
-
-      elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
-         return;
-
       --  If the entity is already set, this has already been resolved in a
       --  generic context, or comes from expansion. Nothing else to do.