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