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-2000 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  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 >= 4 and then Buffer (1 .. 4) = "ada-" then
  68       Startloc := 3;
  69       Buffer (2 .. Len - 2) := Buffer (4 .. Len);
  70       Curlen := Len - 2;
  71       Krlen  := 8;
  72
  73    elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
  74       Startloc := 3;
  75       Buffer (2 .. Len - 3) := Buffer (5 .. Len);
  76       Curlen := Len - 3;
  77       Krlen  := 8;
  78
  79    elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
  80       Startloc := 3;
  81       Buffer (2 .. Len - 5) := Buffer (7 .. Len);
  82       Curlen := Len - 5;
  83       Krlen  := 8;
  84
  85    elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
  86       Startloc := 3;
  87       Buffer (2 .. Len - 9) := Buffer (11 .. Len);
  88       Curlen := Len - 9;
  89       Krlen  := 8;
  90
  91    --  For the renamings in the obsolescent section, we also force krunching
  92    --  to 8 characters, but no other special processing is required here.
  93    --  Note that text_io and calendar are already short enough anyway.
  94
  95    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
  96      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
  97      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
  98      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
  99      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
 100      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
 101      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
 102    then
 103       Startloc := 1;
 104       Krlen    := 8;
 105       Curlen   := Len;
 106
 107    --  Special case of a child unit whose parent unit is a single letter that
 108    --  is A, G, I, or S. In order to prevent confusion with krunched names
 109    --  of predefined units use a tilde rather than a minus as the second
 110    --  character of the file name.  On VMS a tilde is an illegal character
 111    --  in a file name, so a dollar_sign is used instead.
 112
 113    elsif Len > 1
 114      and then Buffer (2) = '-'
 115      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
 116      and then Len <= Maxlen
 117    then
 118       if Hostparm.OpenVMS then
 119          Buffer (2) := '$';
 120       else
 121          Buffer (2) := '~';
 122       end if;
 123
 124       return;
 125
 126    --  Normal case, not a predefined file
 127
 128    else
 129       Startloc := 1;
 130       Curlen   := Len;
 131       Krlen    := Maxlen;
 132    end if;
 133
 134    --  Immediate return if file name is short enough now
 135
 136    if Curlen <= Krlen then
 137       Len := Curlen;
 138       return;
 139    end if;
 140
 141    --  For now, refuse to krunch a name that contains an ESC character (wide
 142    --  character sequence) since it's too much trouble to do this right ???
 143
 144    for J in 1 .. Curlen loop
 145       if Buffer (J) = ASCII.ESC then
 146          return;
 147       end if;
 148    end loop;
 149
 150    --  Count number of separators (minus signs and underscores) and for now
 151    --  replace them by spaces. We keep them around till the end to control
 152    --  the krunching process, and then we eliminate them as the last step
 153
 154    Num_Seps := 0;
 155
 156    for J in Startloc .. Curlen loop
 157       if Buffer (J) = '-' or else Buffer (J) = '_' then
 158          Buffer (J) := ' ';
 159          Num_Seps := Num_Seps + 1;
 160       end if;
 161    end loop;
 162
 163    --  Now we do the one character at a time krunch till we are short enough
 164
 165    while Curlen - Num_Seps > Krlen loop
 166       declare
 167          Long_Length : Natural := 0;
 168          Long_Last   : Natural := 0;
 169          Piece_Start : Natural;
 170          Ptr         : Natural;
 171
 172       begin
 173          Ptr := Startloc;
 174
 175          --  Loop through pieces to find longest piece
 176
 177          while Ptr <= Curlen loop
 178             Piece_Start := Ptr;
 179
 180             --  Loop through characters in one piece of name
 181
 182             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
 183                Ptr := Ptr + 1;
 184             end loop;
 185
 186             if Ptr - Piece_Start > Long_Length then
 187                Long_Length := Ptr - Piece_Start;
 188                Long_Last := Ptr - 1;
 189             end if;
 190
 191             Ptr := Ptr + 1;
 192          end loop;
 193
 194          --  Remove last character of longest piece
 195
 196          if Long_Last < Curlen then
 197             Buffer (Long_Last .. Curlen - 1) :=
 198               Buffer (Long_Last + 1 .. Curlen);
 199          end if;
 200
 201          Curlen := Curlen - 1;
 202       end;
 203    end loop;
 204
 205    --  Final step, remove the spaces
 206
 207    Len := 0;
 208
 209    for J in 1 .. Curlen loop
 210       if Buffer (J) /= ' ' then
 211          Len := Len + 1;
 212          Buffer (Len) := Buffer (J);
 213       end if;
 214    end loop;
 215
 216    return;
 217
 218 end Krunch;