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-2014, 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 Krlen := 8; 99 100 -- For the renamings in the obsolescent section, we also force krunching 101 -- to 8 characters, but no other special processing is required here. 102 -- Note that text_io and calendar are already short enough anyway. 103 104 elsif (Len = 9 and then Buffer (1 .. 9) = "direct_io") 105 or else (Len = 10 and then Buffer (1 .. 10) = "interfaces") 106 or else (Len = 13 and then Buffer (1 .. 13) = "io_exceptions") 107 or else (Len = 12 and then Buffer (1 .. 12) = "machine_code") 108 or else (Len = 13 and then Buffer (1 .. 13) = "sequential_io") 109 or else (Len = 20 and then Buffer (1 .. 20) = "unchecked_conversion") 110 or else (Len = 22 and then Buffer (1 .. 22) = "unchecked_deallocation") 111 then 112 Startloc := 1; 113 Krlen := 8; 114 Curlen := Len; 115 116 -- Special case of a child unit whose parent unit is a single letter that 117 -- is A, G, I, or S. In order to prevent confusion with krunched names 118 -- of predefined units use a tilde rather than a minus as the second 119 -- character of the file name. 120 121 elsif Len > 1 122 and then Buffer (2) = '-' 123 and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's') 124 and then Len <= Maxlen 125 then 126 Buffer (2) := '~'; 127 return; 128 129 -- Normal case, not a predefined file 130 131 else 132 Startloc := 1; 133 Curlen := Len; 134 Krlen := Maxlen; 135 end if; 136 137 -- Immediate return if file name is short enough now 138 139 if Curlen <= Krlen then 140 Len := Curlen; 141 return; 142 end if; 143 144 -- If string contains Wide_Wide, replace by a single z 145 146 J := Startloc; 147 while J <= Curlen - 8 loop 148 if Buffer (J .. J + 8) = "wide_wide" 149 and then (J = Startloc 150 or else Buffer (J - 1) = '-' 151 or else Buffer (J - 1) = '_') 152 and then (J + 8 = Curlen 153 or else Buffer (J + 9) = '-' 154 or else Buffer (J + 9) = '_') 155 then 156 Buffer (J) := 'z'; 157 Buffer (J + 1 .. Curlen - 8) := Buffer (J + 9 .. Curlen); 158 Curlen := Curlen - 8; 159 end if; 160 161 J := J + 1; 162 end loop; 163 164 -- For now, refuse to krunch a name that contains an ESC character (wide 165 -- character sequence) since it's too much trouble to do this right ??? 166 167 for J in 1 .. Curlen loop 168 if Buffer (J) = ASCII.ESC then 169 return; 170 end if; 171 end loop; 172 173 -- Count number of separators (minus signs and underscores) and for now 174 -- replace them by spaces. We keep them around till the end to control 175 -- the krunching process, and then we eliminate them as the last step 176 177 Num_Seps := 0; 178 for J in Startloc .. Curlen loop 179 if Buffer (J) = '-' or else Buffer (J) = '_' then 180 Buffer (J) := ' '; 181 Num_Seps := Num_Seps + 1; 182 end if; 183 end loop; 184 185 -- Now we do the one character at a time krunch till we are short enough 186 187 while Curlen - Num_Seps > Krlen loop 188 declare 189 Long_Length : Natural := 0; 190 Long_Last : Natural := 0; 191 Piece_Start : Natural; 192 Ptr : Natural; 193 194 begin 195 Ptr := Startloc; 196 197 -- Loop through pieces to find longest piece 198 199 while Ptr <= Curlen loop 200 Piece_Start := Ptr; 201 202 -- Loop through characters in one piece of name 203 204 while Ptr <= Curlen and then Buffer (Ptr) /= ' ' loop 205 Ptr := Ptr + 1; 206 end loop; 207 208 if Ptr - Piece_Start > Long_Length then 209 Long_Length := Ptr - Piece_Start; 210 Long_Last := Ptr - 1; 211 end if; 212 213 Ptr := Ptr + 1; 214 end loop; 215 216 -- Remove last character of longest piece 217 218 if Long_Last < Curlen then 219 Buffer (Long_Last .. Curlen - 1) := 220 Buffer (Long_Last + 1 .. Curlen); 221 end if; 222 223 Curlen := Curlen - 1; 224 end; 225 end loop; 226 227 -- Final step, remove the spaces 228 229 Len := 0; 230 231 for J in 1 .. Curlen loop 232 if Buffer (J) /= ' ' then 233 Len := Len + 1; 234 Buffer (Len) := Buffer (J); 235 end if; 236 end loop; 237 238 return; 239end Krunch; 240