From 01099e0465b7851cc5096c58f7b7155937d44960 Mon Sep 17 00:00:00 2001 From: Pascal Obry Date: Fri, 22 May 2015 10:38:07 +0000 Subject: [PATCH] prj-util.ads, [...] (Relative_Path): New routine. 2015-05-22 Pascal Obry * prj-util.ads, prj-util.adb (Relative_Path): New routine. From-SVN: r223542 --- gcc/ada/ChangeLog | 4 +++ gcc/ada/prj-util.adb | 70 +++++++++++++++++++++++++++++++++++++++++++- gcc/ada/prj-util.ads | 6 +++- 3 files changed, 78 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3174cf1f041..0df6bd3da3d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2015-05-22 Pascal Obry + + * prj-util.ads, prj-util.adb (Relative_Path): New routine. + 2015-05-22 Bob Duff * exp_utils.ads, exp_utils.adb (Find_Optional_Prim_Op): New diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 447818daf34..ef500c32198 100644 --- a/gcc/ada/prj-util.adb +++ b/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; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index 892db282a57..b0ffbcc5724 100644 --- a/gcc/ada/prj-util.ads +++ b/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; -- 2.30.2