krunch.ads, krunch.adb (Krunch): New Boolean parameter VMS_On_Target.

2006-10-31  Vincent Celier  <celier@adacore.com>

	* krunch.ads, krunch.adb (Krunch): New Boolean parameter VMS_On_Target.
	When True, apply VMS treatment to children of packages A, G, I and S.
	For F320-016

	* fname-uf.adb (Get_File_Name): Call Krunch with OpenVMS_On_Target

From-SVN: r118270

3 files changed, 40 insertions, 16 deletions

diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb
index 35f2bd6..0ec9405 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -32,6 +32,7 @@ with Namet;    use Namet;
 with Opt;      use Opt;
 with Osint;    use Osint;
 with Table;
+with Targparm; use Targparm;
 with Uname;    use Uname;
 with Widechar; use Widechar;
 
@@ -412,7 +413,8 @@ package body Fname.UF is
                           (Name_Buffer,
                            Name_Len,
                            Integer (Maximum_File_Name_Length),
-                           Debug_Flag_4);
+                           Debug_Flag_4,
+                           OpenVMS_On_Target);
 
                         --  Replace extension
 
diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb
index 53d6285..f15a7a6 100644
--- a/gcc/ada/krunch.adb
+++ b/gcc/ada/krunch.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -34,12 +34,16 @@
 with Hostparm;
 
 procedure Krunch
-  (Buffer    : in out String;
-   Len       : in out Natural;
-   Maxlen    : Natural;
-   No_Predef : Boolean)
+  (Buffer        : in out String;
+   Len           : in out Natural;
+   Maxlen        : Natural;
+   No_Predef     : Boolean;
+   VMS_On_Target : Boolean := False)
 
 is
+   pragma Assert (Buffer'First = 1);
+   --  This is a documented requirement; the assert turns off index warnings
+
    B1       : Character renames Buffer (1);
    Curlen   : Natural;
    Krlen    : Natural;
@@ -119,20 +123,35 @@ begin
    --  is A, G, I, or S. In order to prevent confusion with krunched names
    --  of predefined units use a tilde rather than a minus as the second
    --  character of the file name.  On VMS a tilde is an illegal character
-   --  in a file name, so a dollar_sign is used instead.
+   --  in a file name, two consecutive underlines ("__") are used instead.
 
    elsif Len > 1
      and then Buffer (2) = '-'
      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
      and then Len <= Maxlen
    then
-      if Hostparm.OpenVMS then
-         Buffer (2) := '$';
+      --  When VMS is the host, it is always also the target.
+
+      if Hostparm.OpenVMS or else VMS_On_Target then
+         Len := Len + 1;
+         Buffer (4 .. Len) := Buffer (3 .. Len - 1);
+         Buffer (2) := '_';
+         Buffer (3) := '_';
       else
          Buffer (2) := '~';
       end if;
 
-      return;
+      if Len <= Maxlen then
+         return;
+
+      else
+         --  Case of VMS when the buffer had exactly the length Maxlen and now
+         --  has the length Maxlen + 1: krunching after "__" is needed.
+
+         Startloc := 4;
+         Curlen   := Len;
+         Krlen    := Maxlen;
+      end if;
 
    --  Normal case, not a predefined file
 
diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads
index f5dbdb9..33f9908 100644
--- a/gcc/ada/krunch.ads
+++ b/gcc/ada/krunch.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -120,10 +120,11 @@
 --  unique in the standard predefined libraries.
 
 procedure Krunch
-  (Buffer    : in out String;
-   Len       : in out Natural;
-   Maxlen    : Natural;
-   No_Predef : Boolean);
+  (Buffer        : in out String;
+   Len           : in out Natural;
+   Maxlen        : Natural;
+   No_Predef     : Boolean;
+   VMS_On_Target : Boolean := False);
 pragma Elaborate_Body (Krunch);
 --  The full file name is stored in Buffer (1 .. Len) on entry. The file
 --  name is crunched in place and on return Len is updated, so that the
@@ -132,6 +133,8 @@ pragma Elaborate_Body (Krunch);
 --  case it may be possible that Krunch does not modify Buffer. The fourth
 --  parameter, No_Predef, is a switch which, if set to True, disables the
 --  normal special treatment of predefined library unit file names.
+--  VMS_On_Target, when True, indicates to Krunch to apply the VMS treatment
+--  to the children of package A, G,I or S.
 --
 --  Note: the string Buffer must have a lower bound of 1, and may not
 --  contain any blanks (in particular, it must not have leading blanks).