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-2005 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 procedure Krunch
  36   (Buffer    : in out String;
  37    Len       : in out Natural;
  38    Maxlen    : Natural;
  39    No_Predef : Boolean)
  40
  41 is
  42    B1       : Character renames Buffer (1);
  43    Curlen   : Natural;
  44    Krlen    : Natural;
  45    Num_Seps : Natural;
  46    Startloc : Natural;
  47    J        : Natural;
  48
  49 begin
  50    --  Deal with special predefined children cases. Startloc is the first
  51    --  location for the krunch, set to 1, except for the predefined children
  52    --  case, where it is set to 3, to start after the standard prefix.
  53
  54    if No_Predef then
  55       Startloc := 1;
  56       Curlen := Len;
  57       Krlen := Maxlen;
  58
  59    elsif Len >= 18
  60      and then Buffer (1 .. 17) = "ada-wide_text_io-"
  61    then
  62       Startloc := 3;
  63       Buffer (2 .. 5) := "-wt-";
  64       Buffer (6 .. Len - 12) := Buffer (18 .. Len);
  65       Curlen := Len - 12;
  66       Krlen  := 8;
  67
  68    elsif Len >= 23
  69      and then Buffer (1 .. 22) = "ada-wide_wide_text_io-"
  70    then
  71       Startloc := 3;
  72       Buffer (2 .. 5) := "-zt-";
  73       Buffer (6 .. Len - 17) := Buffer (23 .. Len);
  74       Curlen := Len - 17;
  75       Krlen := 8;
  76
  77    elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then
  78       Startloc := 3;
  79       Buffer (2 .. Len - 2) := Buffer (4 .. Len);
  80       Curlen := Len - 2;
  81       Krlen  := 8;
  82
  83    elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
  84       Startloc := 3;
  85       Buffer (2 .. Len - 3) := Buffer (5 .. Len);
  86       Curlen := Len - 3;
  87       Krlen  := 8;
  88
  89    elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
  90       Startloc := 3;
  91       Buffer (2 .. Len - 5) := Buffer (7 .. Len);
  92       Curlen := Len - 5;
  93       Krlen  := 8;
  94
  95    elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
  96       Startloc := 3;
  97       Buffer (2 .. Len - 9) := Buffer (11 .. Len);
  98       Curlen := Len - 9;
  99       Krlen  := 8;
 100
 101    --  For the renamings in the obsolescent section, we also force krunching
 102    --  to 8 characters, but no other special processing is required here.
 103    --  Note that text_io and calendar are already short enough anyway.
 104
 105    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
 106      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
 107      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
 108      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
 109      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
 110      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
 111      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
 112    then
 113       Startloc := 1;
 114       Krlen    := 8;
 115       Curlen   := Len;
 116
 117    --  Special case of a child unit whose parent unit is a single letter that
 118    --  is A, G, I, or S. In order to prevent confusion with krunched names
 119    --  of predefined units use a tilde rather than a minus as the second
 120    --  character of the file name.  On VMS a tilde is an illegal character
 121    --  in a file name, so a dollar_sign is used instead.
 122
 123    elsif Len > 1
 124      and then Buffer (2) = '-'
 125      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
 126      and then Len <= Maxlen
 127    then
 128       if Hostparm.OpenVMS then
 129          Buffer (2) := '$';
 130       else
 131          Buffer (2) := '~';
 132       end if;
 133
 134       return;
 135
 136    --  Normal case, not a predefined file
 137
 138    else
 139       Startloc := 1;
 140       Curlen   := Len;
 141       Krlen    := Maxlen;
 142    end if;
 143
 144    --  Immediate return if file name is short enough now
 145
 146    if Curlen <= Krlen then
 147       Len := Curlen;
 148       return;
 149    end if;
 150
 151    --  If string contains Wide_Wide, replace by a single z
 152
 153    J := Startloc;
 154    while J <= Curlen - 8 loop
 155       if Buffer (J .. J + 8) = "wide_wide"
 156         and then (J = Startloc
 157                     or else Buffer (J - 1) = '-'
 158                     or else Buffer (J - 1) = '_')
 159         and then (J + 8 = Curlen
 160                     or else Buffer (J + 9) = '-'
 161                     or else Buffer (J + 9) = '_')
 162       then
 163          Buffer (J) := 'z';
 164          Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
 165          Curlen := Curlen - 8;
 166       end if;
 167
 168       J := J + 1;
 169    end loop;
 170
 171    --  For now, refuse to krunch a name that contains an ESC character (wide
 172    --  character sequence) since it's too much trouble to do this right ???
 173
 174    for J in 1 .. Curlen loop
 175       if Buffer (J) = ASCII.ESC then
 176          return;
 177       end if;
 178    end loop;
 179
 180    --  Count number of separators (minus signs and underscores) and for now
 181    --  replace them by spaces. We keep them around till the end to control
 182    --  the krunching process, and then we eliminate them as the last step
 183
 184    Num_Seps := 0;
 185    for J in Startloc .. Curlen loop
 186       if Buffer (J) = '-' or else Buffer (J) = '_' then
 187          Buffer (J) := ' ';
 188          Num_Seps := Num_Seps + 1;
 189       end if;
 190    end loop;
 191
 192    --  Now we do the one character at a time krunch till we are short enough
 193
 194    while Curlen - Num_Seps > Krlen loop
 195       declare
 196          Long_Length : Natural := 0;
 197          Long_Last   : Natural := 0;
 198          Piece_Start : Natural;
 199          Ptr         : Natural;
 200
 201       begin
 202          Ptr := Startloc;
 203
 204          --  Loop through pieces to find longest piece
 205
 206          while Ptr <= Curlen loop
 207             Piece_Start := Ptr;
 208
 209             --  Loop through characters in one piece of name
 210
 211             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
 212                Ptr := Ptr + 1;
 213             end loop;
 214
 215             if Ptr - Piece_Start > Long_Length then
 216                Long_Length := Ptr - Piece_Start;
 217                Long_Last := Ptr - 1;
 218             end if;
 219
 220             Ptr := Ptr + 1;
 221          end loop;
 222
 223          --  Remove last character of longest piece
 224
 225          if Long_Last < Curlen then
 226             Buffer (Long_Last .. Curlen - 1) :=
 227               Buffer (Long_Last + 1 .. Curlen);
 228          end if;
 229
 230          Curlen := Curlen - 1;
 231       end;
 232    end loop;
 233
 234    --  Final step, remove the spaces
 235
 236    Len := 0;
 237
 238    for J in 1 .. Curlen loop
 239       if Buffer (J) /= ' ' then
 240          Len := Len + 1;
 241          Buffer (Len) := Buffer (J);
 242       end if;
 243    end loop;
 244
 245    return;
 246
 247 end Krunch;