prj-util.ads, [...] (Relative_Path): New routine.

2015-05-22  Pascal Obry  <obry@adacore.com>

	* prj-util.ads, prj-util.adb (Relative_Path): New routine.

From-SVN: r223542

gcc/ada/ChangeLog

+2015-05-22  Pascal Obry  <obry@adacore.com>
+
+	* prj-util.ads, prj-util.adb (Relative_Path): New routine.
+
 2015-05-22  Bob Duff  <duff@adacore.com>
 
 	* exp_utils.ads, exp_utils.adb (Find_Optional_Prim_Op): New

gcc/ada/prj-util.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2001-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2015, 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- --
@@ -25,6 +25,8 @@
 
 with Ada.Containers.Indefinite_Ordered_Sets;
 with Ada.Directories;
+with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
+with Ada.Strings.Maps;           use Ada.Strings.Maps;
 with Ada.Unchecked_Deallocation;
 
 with GNAT.Case_Util; use GNAT.Case_Util;
@@ -798,6 +800,71 @@ package body Prj.Util is
       Put (File, L);
    end Put_Line;
 
+   -------------------
+   -- Relative_Path --
+   -------------------
+
+   function Relative_Path (Pathname, To : String) return String is
+
+      function Ensure_Directory (Path : String) return String;
+
+      ----------------------
+      -- Ensure_Directory --
+      ----------------------
+
+      function Ensure_Directory (Path : String) return String is
+      begin
+         if Path'Length = 0
+           or else Path (Path'Last) = Directory_Separator
+           or else Path (Path'Last) = '/' -- on Windows check also for /
+         then
+            return Path;
+         else
+            return Path & Directory_Separator;
+         end if;
+      end Ensure_Directory;
+
+      Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
+
+      P  : String (1 .. Pathname'Length) := Pathname;
+      T  : String (1 .. To'Length) := To;
+
+      Pi : Natural; -- common prefix ending
+      N  : Natural := 0;
+
+   begin
+      pragma Assert (Is_Absolute_Path (Pathname));
+      pragma Assert (Is_Absolute_Path (To));
+
+      --  Use canonical directory separator
+
+      Translate (Source => P, Mapping => Dir_Sep_Map);
+      Translate (Source => T, Mapping => Dir_Sep_Map);
+
+      --  First check for common prefix
+
+      Pi := 1;
+      while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
+         Pi := Pi + 1;
+      end loop;
+
+      --  Cut common prefix at a directory separator
+
+      while Pi > P'First and then P (Pi) /= '/' loop
+         Pi := Pi - 1;
+      end loop;
+
+      --  Count directory under prefix in P, these will be replaced by the
+      --  corresponding number of "..".
+
+      N := Count (T (Pi + 1 .. T'Last), "/");
+      if T (T'Last) /= '/' then
+         N := N + 1;
+      end if;
+
+      return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
+   end Relative_Path;
+
    ---------------------------
    -- Read_Source_Info_File --
    ---------------------------
@@ -1357,4 +1424,5 @@ package body Prj.Util is
          Write_Str (S (First .. S'Last));
       end if;
    end Write_Str;
+
 end Prj.Util;

gcc/ada/prj-util.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2001-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 2001-2015, 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- --
@@ -245,6 +245,10 @@ package Prj.Util is
    --  are handled. This routine must be called only when the project has
    --  been built successfully.
 
+   function Relative_Path (Pathname, To : String) return String;
+   --  Returns the relative pathname which corresponds to Pathname when
+   --  starting from directory to. Both Pathname and To must be absolute paths.
+
 private
    type Text_File_Data is record
       FD                  : File_Descriptor := Invalid_FD;