trunk/gcc/ada/krunch.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               K R U N C H                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Hostparm;
  33
  34 procedure Krunch
  35   (Buffer        : in out String;
  36    Len           : in out Natural;
  37    Maxlen        : Natural;
  38    No_Predef     : Boolean;
  39    VMS_On_Target : Boolean := False)
  40
  41 is
  42    pragma Assert (Buffer'First = 1);
  43    --  This is a documented requirement; the assert turns off index warnings
  44
  45    B1       : Character renames Buffer (1);
  46    Curlen   : Natural;
  47    Krlen    : Natural;
  48    Num_Seps : Natural;
  49    Startloc : Natural;
  50    J        : Natural;
  51
  52 begin
  53    --  Deal with special predefined children cases. Startloc is the first
  54    --  location for the krunch, set to 1, except for the predefined children
  55    --  case, where it is set to 3, to start after the standard prefix.
  56
  57    if No_Predef then
  58       Startloc := 1;
  59       Curlen := Len;
  60       Krlen := Maxlen;
  61
  62    elsif Len >= 18
  63      and then Buffer (1 .. 17) = "ada-wide_text_io-"
  64    then
  65       Startloc := 3;
  66       Buffer (2 .. 5) := "-wt-";
  67       Buffer (6 .. Len - 12) := Buffer (18 .. Len);
  68       Curlen := Len - 12;
  69       Krlen  := 8;
  70
  71    elsif Len >= 23
  72      and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
  73    then
  74       Startloc := 3;
  75       Buffer (2 .. 5) := "-zt-";
  76       Buffer (6 .. Len - 17) := Buffer (23 .. Len);
  77       Curlen := Len - 17;
  78       Krlen := 8;
  79
  80    elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
  81       Startloc := 3;
  82       Buffer (2 .. Len - 2) := Buffer (4 .. Len);
  83       Curlen := Len - 2;
  84       Krlen  := 8;
  85
  86    elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
  87       Startloc := 3;
  88       Buffer (2 .. Len - 3) := Buffer (5 .. Len);
  89       Curlen := Len - 3;
  90       Krlen  := 8;
  91
  92    elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
  93       Startloc := 3;
  94       Buffer (2 .. Len - 5) := Buffer (7 .. Len);
  95       Curlen := Len - 5;
  96       Krlen  := 8;
  97
  98    elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
  99       Startloc := 3;
 100       Buffer (2 .. Len - 9) := Buffer (11 .. Len);
 101       Curlen := Len - 9;
 102       Krlen  := 8;
 103
 104    --  For the renamings in the obsolescent section, we also force krunching
 105    --  to 8 characters, but no other special processing is required here.
 106    --  Note that text_io and calendar are already short enough anyway.
 107
 108    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
 109      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
 110      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
 111      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
 112      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
 113      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
 114      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
 115    then
 116       Startloc := 1;
 117       Krlen    := 8;
 118       Curlen   := Len;
 119
 120    --  Special case of a child unit whose parent unit is a single letter that
 121    --  is A, G, I, or S. In order to prevent confusion with krunched names
 122    --  of predefined units use a tilde rather than a minus as the second
 123    --  character of the file name.  On VMS a tilde is an illegal character
 124    --  in a file name, two consecutive underlines ("__") are used instead.
 125
 126    elsif Len > 1
 127      and then Buffer (2) = '-'
 128      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
 129      and then Len <= Maxlen
 130    then
 131       --  When VMS is the host, it is always also the target
 132
 133       if Hostparm.OpenVMS or else VMS_On_Target then
 134          Len := Len + 1;
 135          Buffer (4 .. Len) := Buffer (3 .. Len - 1);
 136          Buffer (2) := '_';
 137          Buffer (3) := '_';
 138       else
 139          Buffer (2) := '~';
 140       end if;
 141
 142       if Len <= Maxlen then
 143          return;
 144
 145       else
 146          --  Case of VMS when the buffer had exactly the length Maxlen and now
 147          --  has the length Maxlen + 1: krunching after "__" is needed.
 148
 149          Startloc := 4;
 150          Curlen   := Len;
 151          Krlen    := Maxlen;
 152       end if;
 153
 154    --  Normal case, not a predefined file
 155
 156    else
 157       Startloc := 1;
 158       Curlen   := Len;
 159       Krlen    := Maxlen;
 160    end if;
 161
 162    --  Immediate return if file name is short enough now
 163
 164    if Curlen <= Krlen then
 165       Len := Curlen;
 166       return;
 167    end if;
 168
 169    --  If string contains Wide_Wide, replace by a single z
 170
 171    J := Startloc;
 172    while J <= Curlen - 8 loop
 173       if Buffer (J .. J + 8) = "wide_wide"
 174         and then (J = Startloc
 175                     or else Buffer (J - 1) = '-'
 176                     or else Buffer (J - 1) = '_')
 177         and then (J + 8 = Curlen
 178                     or else Buffer (J + 9) = '-'
 179                     or else Buffer (J + 9) = '_')
 180       then
 181          Buffer (J) := 'z';
 182          Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
 183          Curlen := Curlen - 8;
 184       end if;
 185
 186       J := J + 1;
 187    end loop;
 188
 189    --  For now, refuse to krunch a name that contains an ESC character (wide
 190    --  character sequence) since it's too much trouble to do this right ???
 191
 192    for J in 1 .. Curlen loop
 193       if Buffer (J) = ASCII.ESC then
 194          return;
 195       end if;
 196    end loop;
 197
 198    --  Count number of separators (minus signs and underscores) and for now
 199    --  replace them by spaces. We keep them around till the end to control
 200    --  the krunching process, and then we eliminate them as the last step
 201
 202    Num_Seps := 0;
 203    for J in Startloc .. Curlen loop
 204       if Buffer (J) = '-' or else Buffer (J) = '_' then
 205          Buffer (J) := ' ';
 206          Num_Seps := Num_Seps + 1;
 207       end if;
 208    end loop;
 209
 210    --  Now we do the one character at a time krunch till we are short enough
 211
 212    while Curlen - Num_Seps > Krlen loop
 213       declare
 214          Long_Length : Natural := 0;
 215          Long_Last   : Natural := 0;
 216          Piece_Start : Natural;
 217          Ptr         : Natural;
 218
 219       begin
 220          Ptr := Startloc;
 221
 222          --  Loop through pieces to find longest piece
 223
 224          while Ptr <= Curlen loop
 225             Piece_Start := Ptr;
 226
 227             --  Loop through characters in one piece of name
 228
 229             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
 230                Ptr := Ptr + 1;
 231             end loop;
 232
 233             if Ptr - Piece_Start > Long_Length then
 234                Long_Length := Ptr - Piece_Start;
 235                Long_Last := Ptr - 1;
 236             end if;
 237
 238             Ptr := Ptr + 1;
 239          end loop;
 240
 241          --  Remove last character of longest piece
 242
 243          if Long_Last < Curlen then
 244             Buffer (Long_Last .. Curlen - 1) :=
 245               Buffer (Long_Last + 1 .. Curlen);
 246          end if;
 247
 248          Curlen := Curlen - 1;
 249       end;
 250    end loop;
 251
 252    --  Final step, remove the spaces
 253
 254    Len := 0;
 255
 256    for J in 1 .. Curlen loop
 257       if Buffer (J) /= ' ' then
 258          Len := Len + 1;
 259          Buffer (Len) := Buffer (J);
 260       end if;
 261    end loop;
 262
 263    return;
 264
 265 end Krunch;