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