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