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-2016, 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
  99       --  Only fully krunch historical units. For new units, simply use
 100       --  the 'i-' prefix instead of 'interfaces-'. Packages Interfaces.C
 101       --  and Interfaces.Cobol are already in the right form. Package
 102       --  Interfaces.Definitions is krunched for backward compatibility.
 103
 104       if        (Curlen >  3 and then Buffer (3 ..  4) = "c-")
 105         or else (Curlen >  3 and then Buffer (3 ..  4) = "c_")
 106         or else (Curlen = 13 and then Buffer (3 .. 13) = "definitions")
 107         or else (Curlen =  9 and then Buffer (3 ..  9) = "fortran")
 108         or else (Curlen = 16 and then Buffer (3 .. 16) = "packed_decimal")
 109         or else (Curlen >  8 and then Buffer (3 ..  9) = "vxworks")
 110         or else (Curlen >  5 and then Buffer (3 ..  6) = "java")
 111       then
 112          Krlen := 8;
 113       else
 114          Krlen := Maxlen;
 115       end if;
 116
 117    --  For the renamings in the obsolescent section, we also force krunching
 118    --  to 8 characters, but no other special processing is required here.
 119    --  Note that text_io and calendar are already short enough anyway.
 120
 121    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
 122      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
 123      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
 124      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
 125      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
 126      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
 127      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
 128    then
 129       Startloc := 1;
 130       Krlen    := 8;
 131       Curlen   := Len;
 132
 133    --  Special case of a child unit whose parent unit is a single letter that
 134    --  is A, G, I, or S. In order to prevent confusion with krunched names
 135    --  of predefined units use a tilde rather than a minus as the second
 136    --  character of the file name.
 137
 138    elsif Len > 1
 139      and then Buffer (2) = '-'
 140      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
 141      and then Len <= Maxlen
 142    then
 143       Buffer (2) := '~';
 144       return;
 145
 146    --  Normal case, not a predefined file
 147
 148    else
 149       Startloc := 1;
 150       Curlen   := Len;
 151       Krlen    := Maxlen;
 152    end if;
 153
 154    --  Immediate return if file name is short enough now
 155
 156    if Curlen <= Krlen then
 157       Len := Curlen;
 158       return;
 159    end if;
 160
 161    --  If string contains Wide_Wide, replace by a single z
 162
 163    J := Startloc;
 164    while J <= Curlen - 8 loop
 165       if Buffer (J .. J + 8) = "wide_wide"
 166         and then (J = Startloc
 167                     or else Buffer (J - 1) = '-'
 168                     or else Buffer (J - 1) = '_')
 169         and then (J + 8 = Curlen
 170                     or else Buffer (J + 9) = '-'
 171                     or else Buffer (J + 9) = '_')
 172       then
 173          Buffer (J) := 'z';
 174          Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen);
 175          Curlen := Curlen - 8;
 176       end if;
 177
 178       J := J + 1;
 179    end loop;
 180
 181    --  For now, refuse to krunch a name that contains an ESC character (wide
 182    --  character sequence) since it's too much trouble to do this right ???
 183
 184    for J in 1 .. Curlen loop
 185       if Buffer (J) = ASCII.ESC then
 186          return;
 187       end if;
 188    end loop;
 189
 190    --  Count number of separators (minus signs and underscores) and for now
 191    --  replace them by spaces. We keep them around till the end to control
 192    --  the krunching process, and then we eliminate them as the last step
 193
 194    Num_Seps := 0;
 195    for J in Startloc .. Curlen loop
 196       if Buffer (J) = '-' or else Buffer (J) = '_' then
 197          Buffer (J) := ' ';
 198          Num_Seps := Num_Seps + 1;
 199       end if;
 200    end loop;
 201
 202    --  Now we do the one character at a time krunch till we are short enough
 203
 204    while Curlen - Num_Seps > Krlen loop
 205       declare
 206          Long_Length : Natural := 0;
 207          Long_Last   : Natural := 0;
 208          Piece_Start : Natural;
 209          Ptr         : Natural;
 210
 211       begin
 212          Ptr := Startloc;
 213
 214          --  Loop through pieces to find longest piece
 215
 216          while Ptr <= Curlen loop
 217             Piece_Start := Ptr;
 218
 219             --  Loop through characters in one piece of name
 220
 221             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
 222                Ptr := Ptr + 1;
 223             end loop;
 224
 225             if Ptr - Piece_Start > Long_Length then
 226                Long_Length := Ptr - Piece_Start;
 227                Long_Last := Ptr - 1;
 228             end if;
 229
 230             Ptr := Ptr + 1;
 231          end loop;
 232
 233          --  Remove last character of longest piece
 234
 235          if Long_Last < Curlen then
 236             Buffer (Long_Last .. Curlen - 1) :=
 237               Buffer (Long_Last + 1 .. Curlen);
 238          end if;
 239
 240          Curlen := Curlen - 1;
 241       end;
 242    end loop;
 243
 244    --  Final step, remove the spaces
 245
 246    Len := 0;
 247
 248    for J in 1 .. Curlen loop
 249       if Buffer (J) /= ' ' then
 250          Len := Len + 1;
 251          Buffer (Len) := Buffer (J);
 252       end if;
 253    end loop;
 254
 255    return;
 256 end Krunch;