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