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-2019, 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 32procedure Krunch 33 (Buffer : in out String; 34 Len : in out Natural; 35 Maxlen : Natural; 36 No_Predef : Boolean) 37is 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 48begin 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; 256end Krunch; 257