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