2014-07-31 Ed Schonberg <schonberg@adacore.com>

	* sem_util.adb (Has_Preelaborable_Initialization): Check that
	type is tagged before checking whether a user-defined Initialize
	procedure is present.

2014-07-31  Gary Dismukes  <dismukes@adacore.com>

	* a-ngelfu.ads (Sqrt): Augment postcondition.

2014-07-31  Pascal Obry  <obry@adacore.com>

	* prj-nmsc.adb (Check_Library_Attributes): An aggegate library
	directory and ALI directory must be different than all object
	and library directories of aggregated projects.

2014-07-31  Vincent Celier  <celier@adacore.com>

	* prj-pars.adb, prj-conf.ads, prj-conf.adb (Locate_Runtime): Move spec
	to package body, as it is not called from outside. Remove argument
	Project_Tree, no longer used. When runtime cannot be found,
	call Raise_Invalid_Config instead of failing the program.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213330 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 136 insertions, 20 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index bac79b166e2..4f9ed7cae25 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2014-07-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb (Has_Preelaborable_Initialization): Check that
+	type is tagged before checking whether a user-defined Initialize
+	procedure is present.
+
+2014-07-31  Gary Dismukes  <dismukes@adacore.com>
+
+	* a-ngelfu.ads (Sqrt): Augment postcondition.
+
+2014-07-31  Pascal Obry  <obry@adacore.com>
+
+	* prj-nmsc.adb (Check_Library_Attributes): An aggegate library
+	directory and ALI directory must be different than all object
+	and library directories of aggregated projects.
+
+2014-07-31  Vincent Celier  <celier@adacore.com>
+
+	* prj-pars.adb, prj-conf.ads, prj-conf.adb (Locate_Runtime): Move spec
+	to package body, as it is not called from outside. Remove argument
+	Project_Tree, no longer used. When runtime cannot be found,
+	call Raise_Invalid_Config instead of failing the program.
+
 2014-07-31  Robert Dewar  <dewar@adacore.com>
 
 	* bindgen.adb (Gen_Output_File_Ada): Generate pragma Suppress
diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads
index 0d551015711..556992322b3 100644
--- a/gcc/ada/a-ngelfu.ads
+++ b/gcc/ada/a-ngelfu.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2012-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2012-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,8 +41,22 @@ package Ada.Numerics.Generic_Elementary_Functions is
 
    function Sqrt (X : Float_Type'Base) return Float_Type'Base with
      Post => Sqrt'Result >= 0.0
-               and then (if X = 0.0 then Sqrt'Result = 0.0)
-               and then (if X = 1.0 then Sqrt'Result = 1.0);
+
+       and then (if X = 0.0 then Sqrt'Result = 0.0)
+
+       and then (if X = 1.0 then Sqrt'Result = 1.0)
+
+       --  If X is positive, the result of Sqrt is positive. This property is
+       --  useful in particular for static analysis. The property that X is
+       --  positive is not expressed as (X > 0), as the value X may be held in
+       --  registers that have larger range and precision on some architecture
+
+       --  (for example, on x86 using x387 FPU, as opposed to SSE2). So, it
+       --  might be possible for X to be 2.0**(-5000) or so, which could cause
+       --  the number to compare as greater than 0, but Sqrt would still return
+       --  a zero result.
+
+       and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0);
 
    function Log (X : Float_Type'Base) return Float_Type'Base
    with
diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb
index 1becd7028c3..b500e7b2f50 100644
--- a/gcc/ada/prj-conf.adb
+++ b/gcc/ada/prj-conf.adb
@@ -64,6 +64,14 @@ package body Prj.Conf is
    --  Stores the runtime names for the various languages. This is in general
    --  set from a --RTS command line option.
 
+   procedure Locate_Runtime
+     (Language     : Name_Id;
+      Env          : Prj.Tree.Environment);
+   --  If RTS_Name is a base name (a name without path separator), then
+   --  do nothing. Otherwise, convert it to an absolute path (possibly by
+   --  searching it in the project path) and call Set_Runtime_For with the
+   --  absolute path. Raise Invalid_Config if the path does not exist.
+
    -----------------------
    -- Local_Subprograms --
    -----------------------
@@ -721,7 +729,7 @@ package body Prj.Conf is
                               Set_Runtime_For
                                 (Name_Ada,
                                  Name_Buffer (7 .. Name_Len));
-                              Locate_Runtime (Name_Ada, Project_Tree, Env);
+                              Locate_Runtime (Name_Ada, Env);
                            end if;
 
                         elsif Name_Len > 7
@@ -748,7 +756,7 @@ package body Prj.Conf is
 
                                  if not Runtime_Name_Set_For (Lang) then
                                     Set_Runtime_For (Lang, RTS);
-                                    Locate_Runtime (Lang, Project_Tree, Env);
+                                    Locate_Runtime (Lang, Env);
                                  end if;
                               end;
                            end if;
@@ -1518,7 +1526,6 @@ package body Prj.Conf is
 
    procedure Locate_Runtime
      (Language     : Name_Id;
-      Project_Tree : Prj.Project_Tree_Ref;
       Env          : Prj.Tree.Environment)
    is
       function Is_Base_Name (Path : String) return Boolean;
@@ -1555,7 +1562,7 @@ package body Prj.Conf is
            Find_Rts_In_Path (Env.Project_Path, RTS_Name);
 
          if Full_Path = null then
-            Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name);
+            Raise_Invalid_Config ("cannot find RTS " & RTS_Name);
          end if;
 
          Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all));
diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads
index df830ad93b6..029310f9dd1 100644
--- a/gcc/ada/prj-conf.ads
+++ b/gcc/ada/prj-conf.ads
@@ -216,13 +216,4 @@ package Prj.Conf is
    function Runtime_Name_Set_For (Language : Name_Id) return Boolean;
    --  Returns True only if Set_Runtime_For has been called for the Language
 
-   procedure Locate_Runtime
-     (Language     : Name_Id;
-      Project_Tree : Prj.Project_Tree_Ref;
-      Env          : Prj.Tree.Environment);
-   --  If RTS_Name is a base name (a name without path separator), then
-   --  do nothing. Otherwise, convert it to an absolute path (possibly by
-   --  searching it in the project path) and call Set_Runtime_For with the
-   --  absolute path. Fail the program if the path does not exist.
-
 end Prj.Conf;
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 19c12de053d..96d3777f116 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -3028,6 +3028,76 @@ package body Prj.Nmsc is
       procedure Check_Library (Proj : Project_Id; Extends : Boolean);
       --  Check if an imported or extended project if also a library project
 
+      procedure Check_Aggregate_Library_Dirs;
+
+      ----------------------------------
+      -- Check_Aggregate_Library_Dirs --
+      ----------------------------------
+
+      procedure Check_Aggregate_Library_Dirs is
+         procedure Process_Aggregate (Proj : Project_Id);
+
+         procedure Process_Aggregate (Proj : Project_Id) is
+
+            Agg : Aggregated_Project_List := Proj.Aggregated_Projects;
+
+         begin
+            while Agg /= null loop
+               Error_Msg_Name_1 := Agg.Project.Name;
+
+               if Agg.Project.Qualifier /= Aggregate_Library and then
+                 Project.Library_ALI_Dir.Name
+                 = Agg.Project.Object_Directory.Name
+               then
+                  Error_Msg
+                    (Data.Flags,
+                     "aggregate library 'A'L'I directory cannot be shared with"
+                     & " object directory of aggregated project %%",
+                     The_Lib_Kind.Location, Project);
+
+               elsif Project.Library_ALI_Dir.Name
+                 = Agg.Project.Library_Dir.Name
+               then
+                  Error_Msg
+                    (Data.Flags,
+                     "aggregate library 'A'L'I directory cannot be shared with"
+                     & " library directory of aggregated project %%",
+                     The_Lib_Kind.Location, Project);
+
+               elsif Agg.Project.Qualifier /= Aggregate_Library and then
+                 Project.Library_Dir.Name
+                 = Agg.Project.Object_Directory.Name
+               then
+                  Error_Msg
+                    (Data.Flags,
+                     "aggregate library directory cannot be shared with"
+                     & " object directory of aggregated project %%",
+                     The_Lib_Kind.Location, Project);
+
+               elsif Project.Library_Dir.Name
+                 = Agg.Project.Library_Dir.Name
+               then
+                  Error_Msg
+                    (Data.Flags,
+                     "aggregate library directory cannot be shared with"
+                     & " library directory of aggregated project %%",
+                     The_Lib_Kind.Location, Project);
+               end if;
+
+               if Agg.Project.Qualifier = Aggregate_Library then
+                  Process_Aggregate (Agg.Project);
+               end if;
+
+               Agg := Agg.Next;
+            end loop;
+         end Process_Aggregate;
+
+      begin
+         if Project.Qualifier = Aggregate_Library then
+            Process_Aggregate (Project);
+         end if;
+      end Check_Aggregate_Library_Dirs;
+
       -------------------
       -- Check_Library --
       -------------------
@@ -3745,6 +3815,13 @@ package body Prj.Nmsc is
          Continuation := Continuation_String'Access;
       end if;
 
+      --  Check that aggregated libraries do not share the aggregate
+      --  Library_ALI_Dir.
+
+      if Project.Qualifier = Aggregate_Library then
+         Check_Aggregate_Library_Dirs;
+      end if;
+
       if Project.Library and not Data.In_Aggregate_Lib then
 
          --  Record the library name
diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb
index 7fbce49fa9a..a37e13aec93 100644
--- a/gcc/ada/prj-pars.adb
+++ b/gcc/ada/prj-pars.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2001-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2014, 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- --
@@ -103,8 +103,8 @@ package body Prj.Pars is
             Success := The_Project /= No_Project;
 
          exception
-            when Invalid_Config =>
-               Success := False;
+            when E : Invalid_Config =>
+               Osint.Fail (Exception_Message (E));
          end;
 
          Prj.Err.Finalize;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index af04384cc93..f6c150f0759 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -8189,10 +8189,13 @@ package body Sem_Util is
          end if;
 
          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
-         --  with a user defined Initialize procedure does not have PI.
+         --  with a user defined Initialize procedure does not have PI. If
+         --  the type is untagged, the control primitives come from a component
+         --  that has already been checked.
 
          if Has_PE
            and then Is_Controlled (E)
+           and then Is_Tagged_Type (E)
            and then Has_Overriding_Initialize (E)
          then
             Has_PE := False;
@@ -16456,6 +16459,7 @@ package body Sem_Util is
          Stmt := Original_Node (N);
       end if;
 
+      --    and then Ekind (Entity (Identifier (Stmt))) = E_Loop
       return
         Nkind (Stmt) = N_Loop_Statement
           and then Present (Identifier (Stmt))