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 --                            $Revision: 1.16 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Hostparm;
  37 procedure Krunch
  38   (Buffer    : in out String;
  39    Len       : in out Natural;
  40    Maxlen    : Natural;
  41    No_Predef : Boolean)
  42
  43 is
  44    B1       : Character renames Buffer (1);
  45    Curlen   : Natural;
  46    Krlen    : Natural;
  47    Num_Seps : Natural;
  48    Startloc : 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 >= 4 and then Buffer (1 .. 4) = "ada-" then
  70       Startloc := 3;
  71       Buffer (2 .. Len - 2) := Buffer (4 .. Len);
  72       Curlen := Len - 2;
  73       Krlen  := 8;
  74
  75    elsif Len >= 5 and then Buffer (1 .. 5) = "gnat-" then
  76       Startloc := 3;
  77       Buffer (2 .. Len - 3) := Buffer (5 .. Len);
  78       Curlen := Len - 3;
  79       Krlen  := 8;
  80
  81    elsif Len >= 7 and then Buffer (1 .. 7) = "system-" then
  82       Startloc := 3;
  83       Buffer (2 .. Len - 5) := Buffer (7 .. Len);
  84       Curlen := Len - 5;
  85       Krlen  := 8;
  86
  87    elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then
  88       Startloc := 3;
  89       Buffer (2 .. Len - 9) := Buffer (11 .. Len);
  90       Curlen := Len - 9;
  91       Krlen  := 8;
  92
  93    --  For the renamings in the obsolescent section, we also force krunching
  94    --  to 8 characters, but no other special processing is required here.
  95    --  Note that text_io and calendar are already short enough anyway.
  96
  97    elsif     (Len =  9 and then Buffer (1 ..  9) = "direct_io")
  98      or else (Len = 10 and then Buffer (1 .. 10) = "interfaces")
  99      or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions")
 100      or else (Len = 12 and then Buffer (1 .. 12) = "machine_code")
 101      or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io")
 102      or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion")
 103      or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation")
 104    then
 105       Startloc := 1;
 106       Krlen    := 8;
 107       Curlen   := Len;
 108
 109    --  Special case of a child unit whose parent unit is a single letter that
 110    --  is A, G, I, or S. In order to prevent confusion with krunched names
 111    --  of predefined units use a tilde rather than a minus as the second
 112    --  character of the file name.  On VMS a tilde is an illegal character
 113    --  in a file name, so a dollar_sign is used instead.
 114
 115    elsif Len > 1
 116      and then Buffer (2) = '-'
 117      and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
 118      and then Len <= Maxlen
 119    then
 120       if Hostparm.OpenVMS then
 121          Buffer (2) := '$';
 122       else
 123          Buffer (2) := '~';
 124       end if;
 125
 126       return;
 127
 128    --  Normal case, not a predefined file
 129
 130    else
 131       Startloc := 1;
 132       Curlen   := Len;
 133       Krlen    := Maxlen;
 134    end if;
 135
 136    --  Immediate return if file name is short enough now
 137
 138    if Curlen <= Krlen then
 139       Len := Curlen;
 140       return;
 141    end if;
 142
 143    --  For now, refuse to krunch a name that contains an ESC character (wide
 144    --  character sequence) since it's too much trouble to do this right ???
 145
 146    for J in 1 .. Curlen loop
 147       if Buffer (J) = ASCII.ESC then
 148          return;
 149       end if;
 150    end loop;
 151
 152    --  Count number of separators (minus signs and underscores) and for now
 153    --  replace them by spaces. We keep them around till the end to control
 154    --  the krunching process, and then we eliminate them as the last step
 155
 156    Num_Seps := 0;
 157
 158    for J in Startloc .. Curlen loop
 159       if Buffer (J) = '-' or else Buffer (J) = '_' then
 160          Buffer (J) := ' ';
 161          Num_Seps := Num_Seps + 1;
 162       end if;
 163    end loop;
 164
 165    --  Now we do the one character at a time krunch till we are short enough
 166
 167    while Curlen - Num_Seps > Krlen loop
 168       declare
 169          Long_Length : Natural := 0;
 170          Long_Last   : Natural := 0;
 171          Piece_Start : Natural;
 172          Ptr         : Natural;
 173
 174       begin
 175          Ptr := Startloc;
 176
 177          --  Loop through pieces to find longest piece
 178
 179          while Ptr <= Curlen loop
 180             Piece_Start := Ptr;
 181
 182             --  Loop through characters in one piece of name
 183
 184             while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop
 185                Ptr := Ptr + 1;
 186             end loop;
 187
 188             if Ptr - Piece_Start > Long_Length then
 189                Long_Length := Ptr - Piece_Start;
 190                Long_Last := Ptr - 1;
 191             end if;
 192
 193             Ptr := Ptr + 1;
 194          end loop;
 195
 196          --  Remove last character of longest piece
 197
 198          if Long_Last < Curlen then
 199             Buffer (Long_Last .. Curlen - 1) :=
 200               Buffer (Long_Last + 1 .. Curlen);
 201          end if;
 202
 203          Curlen := Curlen - 1;
 204       end;
 205    end loop;
 206
 207    --  Final step, remove the spaces
 208
 209    Len := 0;
 210
 211    for J in 1 .. Curlen loop
 212       if Buffer (J) /= ' ' then
 213          Len := Len + 1;
 214          Buffer (Len) := Buffer (J);
 215       end if;
 216    end loop;
 217
 218    return;
 219
 220 end Krunch;