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