[multiple changes]

2009-06-21  Thomas Quinot  <quinot@adacore.com>

	* exp_ch3.adb, exp_prag.adb, exp_util.adb, exp_util.ads, freeze.adb,
	sem_ch13.adb, sem_elab.adb (Exp_Prag.Expand_Pragma_Import_Or_Interface):
	Factor out code to new subprogram...
	(Exp_Util.Find_Init_Call): New shared routine to find the init proc call
	for a default initialized variable.
	(Freeze.Check_Address_Clause): Do not reset Has_Delayed_Freeze on an
	entity that has an associated freeze node.
	(Sem_Ch13.Analyze_Attribute_Definition_Clause, case Address):
	If there is an init call for the object, defer it to the object freeze
	point.
	(Check_Elab_Call.Find_Init_Call): Rename to Check_Init_Call, to avoid
	name clash with new subprogram introduced in Exp_Util.

2009-06-21  Robert Dewar  <dewar@adacore.com>

	* einfo.ads: Minor reformatting

From-SVN: r148764

gcc/ada/ChangeLog

+2009-06-21  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_ch3.adb, exp_prag.adb, exp_util.adb, exp_util.ads, freeze.adb,
+	sem_ch13.adb, sem_elab.adb (Exp_Prag.Expand_Pragma_Import_Or_Interface):
+	Factor out code to new subprogram...
+	(Exp_Util.Find_Init_Call): New shared routine to find the init proc call
+	for a default initialized variable.
+	(Freeze.Check_Address_Clause): Do not reset Has_Delayed_Freeze on an
+	entity that has an associated freeze node.
+	(Sem_Ch13.Analyze_Attribute_Definition_Clause, case Address):
+	If there is an init call for the object, defer it to the object freeze
+	point.
+	(Check_Elab_Call.Find_Init_Call): Rename to Check_Init_Call, to avoid
+	name clash with new subprogram introduced in Exp_Util.
+
+2009-06-21  Robert Dewar  <dewar@adacore.com>
+
+	* einfo.ads: Minor reformatting
+
 2009-06-21  Ed Falis  <falis@adacore.com>
 
 	* env.c (__gnat_environ): return NULL for vThreads - unimplemented

gcc/ada/einfo.ads

@@ -241,7 +241,7 @@ package Einfo is
 
 --  For elementary types other than discrete and fixed-point types, the
 --  Object_Size and Value_Size are the same (and equivalent to the RM
---  attribute Size).  Only Size may be specified for such types.
+--  attribute Size). Only Size may be specified for such types.
 
 --  For composite types, Object_Size and Value_Size are computed from their
 --  respective value for the type of each element as well as the layout.

gcc/ada/exp_ch3.adb

@@ -4380,8 +4380,12 @@ package body Exp_Ch3 is
             --  object being initialized. This is because the call is not a
             --  source level call. This works fine, because the only possible
             --  statements depending on freeze status that can appear after the
-            --  _Init call are rep clauses which can safely appear after actual
-            --  references to the object.
+            --  Init_Proc call are rep clauses which can safely appear after
+            --  actual references to the object. Note that this call may
+            --  subsequently be removed (if a pragma Import is encountered),
+            --  or moved to the freeze actions for the object (e.g. if an
+            --  address clause is applied to the object, causing it to get
+            --  delayed freezing).
 
             Id_Ref := New_Reference_To (Def_Id, Loc);
             Set_Must_Not_Freeze (Id_Ref);

gcc/ada/exp_prag.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -29,7 +29,6 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Exp_Ch11; use Exp_Ch11;
-with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Expander; use Expander;
 with Namet;    use Namet;
@@ -485,29 +484,17 @@ package body Exp_Prag is
 
    procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
       Def_Id    : constant Entity_Id := Entity (Arg2 (N));
-      Typ       : Entity_Id;
       Init_Call : Node_Id;
 
    begin
       if Ekind (Def_Id) = E_Variable then
-         Typ  := Etype (Def_Id);
 
-         --  Iterate from declaration of object to import pragma, to find
-         --  generated initialization call for object, if any.
+         --  Find generated initialization call for object, if any
 
-         Init_Call := Next (Parent (Def_Id));
-         while Present (Init_Call) and then Init_Call /= N loop
-            if Has_Non_Null_Base_Init_Proc (Typ)
-              and then Nkind (Init_Call) = N_Procedure_Call_Statement
-              and then Is_Entity_Name (Name (Init_Call))
-              and then Entity (Name (Init_Call)) = Base_Init_Proc (Typ)
-            then
-               Remove (Init_Call);
-               exit;
-            else
-               Next (Init_Call);
-            end if;
-         end loop;
+         Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);
+         if Present (Init_Call) then
+            Remove (Init_Call);
+         end if;
 
          --  Any default initialization expression should be removed
          --  (e.g., null defaults for access objects, zero initialization
@@ -515,9 +502,7 @@ package body Exp_Prag is
          --  have explicit initialization, so the expression must have
          --  been generated by the compiler.
 
-         if Init_Call = N
-           and then Present (Expression (Parent (Def_Id)))
-         then
+         if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
             Set_Expression (Parent (Def_Id), Empty);
          end if;
       end if;

gcc/ada/exp_util.adb

@@ -1398,6 +1398,74 @@ package body Exp_Util is
       end if;
    end Expand_Subtype_From_Expr;
 
+   --------------------
+   -- Find_Init_Call --
+   --------------------
+
+   function Find_Init_Call
+     (Var        : Entity_Id;
+      Rep_Clause : Node_Id) return Node_Id
+   is
+      Typ : constant Entity_Id := Etype (Var);
+
+      Init_Proc : Entity_Id;
+      --  Initialization procedure for Typ
+
+      function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
+      --  Look for init call for Var starting at From and scanning the
+      --  enclosing list until Rep_Clause or the end of the list is reached.
+
+      ----------------------------
+      -- Find_Init_Call_In_List --
+      ----------------------------
+
+      function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
+         Init_Call : Node_Id;
+      begin
+         Init_Call := From;
+
+         while Present (Init_Call) and then Init_Call /= Rep_Clause loop
+            if Nkind (Init_Call) = N_Procedure_Call_Statement
+                 and then Is_Entity_Name (Name (Init_Call))
+                 and then Entity (Name (Init_Call)) = Init_Proc
+            then
+               return Init_Call;
+            end if;
+            Next (Init_Call);
+         end loop;
+
+         return Empty;
+      end Find_Init_Call_In_List;
+
+      Init_Call : Node_Id;
+
+   --  Start of processing for Find_Init_Call
+
+   begin
+      if not Has_Non_Null_Base_Init_Proc (Typ) then
+         --  No init proc for the type, so obviously no call to be found
+
+         return Empty;
+      end if;
+
+      Init_Proc := Base_Init_Proc (Typ);
+
+      --  First scan the list containing the declaration of Var
+
+      Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
+
+      --  If not found, also look on Var's freeze actions list, if any, since
+      --  the init call may have been moved there (case of an address clause
+      --  applying to Var).
+
+      if No (Init_Call) and then Present (Freeze_Node (Var)) then
+         Init_Call := Find_Init_Call_In_List
+                        (First (Actions (Freeze_Node (Var))));
+      end if;
+
+      return Init_Call;
+   end Find_Init_Call;
+
    ------------------------
    -- Find_Interface_ADT --
    ------------------------

gcc/ada/exp_util.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -343,6 +343,14 @@ package Exp_Util is
    --  declarations and/or allocations when the type is indefinite (including
    --  class-wide).
 
+   function Find_Init_Call
+     (Var        : Entity_Id;
+      Rep_Clause : Node_Id) return Node_Id;
+   --  Look for init_proc call for variable Var, either among declarations
+   --  between that of Var and a subsequent Rep_Clause applying to Var, or
+   --  in the list of freeze actions associated with Var, and if found, return
+   --  that call node.
+
    function Find_Interface_ADT
      (T     : Entity_Id;
       Iface : Entity_Id) return Elmt_Id;

gcc/ada/freeze.adb

@@ -536,10 +536,19 @@ package body Freeze is
          --  Otherwise, we require the address clause to be constant because
          --  the call to the initialization procedure (or the attach code) has
          --  to happen at the point of the declaration.
+         --  Actually the IP call has been moved to the freeze actions
+         --  anyway, so maybe we can relax this restriction???
 
          else
             Check_Constant_Address_Clause (Expr, E);
-            Set_Has_Delayed_Freeze (E, False);
+
+            --  Has_Delayed_Freeze was set on E when the address clause was
+            --  analyzed. Reset the flag now unless freeze actions were
+            --  attached to it in the mean time.
+
+            if No (Freeze_Node (E)) then
+               Set_Has_Delayed_Freeze (E, False);
+            end if;
          end if;
 
          if not Error_Posted (Expr)
@@ -2594,6 +2603,7 @@ package body Freeze is
                      if Is_Array_Type (R_Type)
                        and then not Is_Constrained (R_Type)
                        and then not Is_Imported (E)
+                       and then VM_Target = No_VM
                        and then Has_Foreign_Convention (E)
                        and then Warn_On_Export_Import
                        and then not Has_Warnings_Off (E)
@@ -5037,6 +5047,7 @@ package body Freeze is
               and then not Is_Constrained (Retype)
               and then Mechanism (E) not in Descriptor_Codes
               and then Warn_On_Export_Import
+              and then VM_Target = No_VM
             then
                Error_Msg_N
                 ("?foreign convention function& should not return " &

gcc/ada/sem_ch13.adb

@@ -977,6 +977,21 @@ package body Sem_Ch13 is
 
                   Set_Has_Delayed_Freeze (U_Ent);
 
+                  --  If an initialization call has been generated for this
+                  --  object, it needs to be deferred to after the freeze node
+                  --  we have just now added, otherwise GIGI will see a
+                  --  reference to the variable (as actual to the IP call)
+                  --  before its definition.
+
+                  declare
+                     Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
+                  begin
+                     if Present (Init_Call) then
+                        Remove (Init_Call);
+                        Append_Freeze_Action (U_Ent, Init_Call);
+                     end if;
+                  end;
+
                   if Is_Exported (U_Ent) then
                      Error_Msg_N
                        ("& cannot be exported if an address clause is given",

gcc/ada/sem_elab.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1997-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1997-2009, 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- --
@@ -1460,18 +1460,18 @@ package body Sem_Elab is
          Process_Init_Proc : declare
             Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
 
-            function Find_Init_Call (Nod : Node_Id) return Traverse_Result;
+            function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
             --  Find subprogram calls within body of Init_Proc for Traverse
             --  instantiation below.
 
-            procedure Traverse_Body is new Traverse_Proc (Find_Init_Call);
+            procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
             --  Traversal procedure to find all calls with body of Init_Proc
 
-            --------------------
-            -- Find_Init_Call --
-            --------------------
+            ---------------------
+            -- Check_Init_Call --
+            ---------------------
 
-            function Find_Init_Call (Nod : Node_Id) return Traverse_Result is
+            function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
                Func : Entity_Id;
 
             begin
@@ -1491,7 +1491,7 @@ package body Sem_Elab is
                else
                   return OK;
                end if;
-            end Find_Init_Call;
+            end Check_Init_Call;
 
          --  Start of processing for Process_Init_Proc