1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F N A M E . U F -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Alloc; 28with Debug; use Debug; 29with Fmap; use Fmap; 30with Krunch; 31with Namet; use Namet; 32with Opt; use Opt; 33with Osint; use Osint; 34with Table; 35with Widechar; use Widechar; 36 37with GNAT.HTable; 38 39package body Fname.UF is 40 41 -------------------------------------------------------- 42 -- Declarations for Handling Source_File_Name pragmas -- 43 -------------------------------------------------------- 44 45 type SFN_Entry is record 46 U : Unit_Name_Type; -- Unit name 47 F : File_Name_Type; -- Spec/Body file name 48 end record; 49 -- Record single Unit_Name type call to Set_File_Name 50 51 package SFN_Table is new Table.Table ( 52 Table_Component_Type => SFN_Entry, 53 Table_Index_Type => Int, 54 Table_Low_Bound => 0, 55 Table_Initial => Alloc.SFN_Table_Initial, 56 Table_Increment => Alloc.SFN_Table_Increment, 57 Table_Name => "SFN_Table"); 58 -- Table recording all Unit_Name calls to Set_File_Name 59 60 type SFN_Header_Num is range 0 .. 100; 61 62 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num; 63 -- Compute hash index for use by Simple_HTable 64 65 No_Entry : constant Int := -1; 66 -- Signals no entry in following table 67 68 package SFN_HTable is new GNAT.HTable.Simple_HTable ( 69 Header_Num => SFN_Header_Num, 70 Element => Int, 71 No_Element => No_Entry, 72 Key => Unit_Name_Type, 73 Hash => SFN_Hash, 74 Equal => "="); 75 -- Hash table allowing rapid access to SFN_Table, the element value 76 -- is an index into this table. 77 78 type SFN_Pattern_Entry is record 79 Pat : String_Ptr; -- File name pattern (with asterisk in it) 80 Typ : Character; -- 'S'/'B'/'U' for spec/body/subunit 81 Dot : String_Ptr; -- Dot_Separator string 82 Cas : Casing_Type; -- Upper/Lower/Mixed 83 end record; 84 -- Records single call to Set_File_Name_Patterm 85 86 package SFN_Patterns is new Table.Table ( 87 Table_Component_Type => SFN_Pattern_Entry, 88 Table_Index_Type => Int, 89 Table_Low_Bound => 1, 90 Table_Initial => 10, 91 Table_Increment => 100, 92 Table_Name => "SFN_Patterns"); 93 -- Table recording all calls to Set_File_Name_Pattern. Note that the 94 -- first two entries are set to represent the standard GNAT rules 95 -- for file naming. 96 97 ----------------------- 98 -- File_Name_Of_Body -- 99 ----------------------- 100 101 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is 102 begin 103 Get_Name_String (Name); 104 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b"; 105 Name_Len := Name_Len + 2; 106 return Get_File_Name (Name_Enter, Subunit => False); 107 end File_Name_Of_Body; 108 109 ----------------------- 110 -- File_Name_Of_Spec -- 111 ----------------------- 112 113 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is 114 begin 115 Get_Name_String (Name); 116 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s"; 117 Name_Len := Name_Len + 2; 118 return Get_File_Name (Name_Enter, Subunit => False); 119 end File_Name_Of_Spec; 120 121 ------------------- 122 -- Get_File_Name -- 123 ------------------- 124 125 function Get_File_Name 126 (Uname : Unit_Name_Type; 127 Subunit : Boolean) return File_Name_Type 128 is 129 Unit_Char : Character; 130 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit 131 132 Unit_Char_Search : Character; 133 -- Same as Unit_Char, except that in the case of 'u' for a subunit, 134 -- we set Unit_Char_Search to 'b' if we do not find a subunit match. 135 136 N : Int; 137 138 Pname : File_Name_Type := No_File; 139 Fname : File_Name_Type := No_File; 140 -- Path name and File name for mapping 141 142 begin 143 -- Null or error name means that some previous error occurred 144 -- This is an unrecoverable error, so signal it. 145 146 if Uname <= Error_Name then 147 raise Unrecoverable_Error; 148 end if; 149 150 -- Look in the map from unit names to file names 151 152 Fname := Mapped_File_Name (Uname); 153 154 -- If the unit name is already mapped, return the corresponding 155 -- file name from the map. 156 157 if Fname /= No_File then 158 return Fname; 159 end if; 160 161 -- If there is a specific SFN pragma, return the corresponding file name 162 163 N := SFN_HTable.Get (Uname); 164 165 if N /= No_Entry then 166 return SFN_Table.Table (N).F; 167 end if; 168 169 -- Here for the case where the name was not found in the table 170 171 Get_Decoded_Name_String (Uname); 172 173 -- A special fudge, normally we don't have operator symbols present, 174 -- since it is always an error to do so. However, if we do, at this 175 -- stage it has a leading double quote. 176 177 -- What we do in this case is to go back to the undecoded name, which 178 -- is of the form, for example: 179 180 -- Oand%s 181 182 -- and build a file name that looks like: 183 184 -- _and_.ads 185 186 -- which is bit peculiar, but we keep it that way. This means that 187 -- we avoid bombs due to writing a bad file name, and w get expected 188 -- error processing downstream, e.g. a compilation following gnatchop. 189 190 if Name_Buffer (1) = '"' then 191 Get_Name_String (Uname); 192 Name_Len := Name_Len + 1; 193 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1); 194 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2); 195 Name_Buffer (Name_Len - 2) := '_'; 196 Name_Buffer (1) := '_'; 197 end if; 198 199 -- Deal with spec or body suffix 200 201 Unit_Char := Name_Buffer (Name_Len); 202 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's'); 203 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%'); 204 Name_Len := Name_Len - 2; 205 206 if Subunit then 207 Unit_Char := 'u'; 208 end if; 209 210 -- Now we need to find the proper translation of the name 211 212 declare 213 Uname : constant String (1 .. Name_Len) := 214 Name_Buffer (1 .. Name_Len); 215 216 Pent : Nat; 217 Plen : Natural; 218 Fnam : File_Name_Type := No_File; 219 J : Natural; 220 Dot : String_Ptr; 221 Dotl : Natural; 222 223 Is_Predef : Boolean; 224 -- Set True for predefined file 225 226 function C (N : Natural) return Character; 227 -- Return N'th character of pattern 228 229 function C (N : Natural) return Character is 230 begin 231 return SFN_Patterns.Table (Pent).Pat (N); 232 end C; 233 234 -- Start of search through pattern table 235 236 begin 237 -- Search pattern table to find a matching entry. In the general 238 -- case we do two complete searches. The first time through we 239 -- stop only if a matching file is found, the second time through 240 -- we accept the first match regardless. Note that there will 241 -- always be a match the second time around, because of the 242 -- default entries at the end of the table. 243 244 for No_File_Check in False .. True loop 245 Unit_Char_Search := Unit_Char; 246 247 <<Repeat_Search>> 248 -- The search is repeated with Unit_Char_Search set to b, if an 249 -- initial search for the subunit case fails to find any match. 250 251 Pent := SFN_Patterns.First; 252 while Pent <= SFN_Patterns.Last loop 253 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then 254 Name_Len := 0; 255 256 -- Determine if we have a predefined file name 257 258 Name_Len := Uname'Length; 259 Name_Buffer (1 .. Name_Len) := Uname; 260 Is_Predef := 261 Is_Predefined_File_Name (Renamings_Included => True); 262 263 -- Found a match, execute the pattern 264 265 Name_Len := Uname'Length; 266 Name_Buffer (1 .. Name_Len) := Uname; 267 268 -- Apply casing, except that we do not do this for the case 269 -- of a predefined library file. For the latter, we always 270 -- use the all lower case name, regardless of the setting. 271 272 if not Is_Predef then 273 Set_Casing (SFN_Patterns.Table (Pent).Cas); 274 end if; 275 276 -- If dot translation required do it 277 278 Dot := SFN_Patterns.Table (Pent).Dot; 279 Dotl := Dot.all'Length; 280 281 if Dot.all /= "." then 282 J := 1; 283 284 while J <= Name_Len loop 285 if Name_Buffer (J) = '.' then 286 287 if Dotl = 1 then 288 Name_Buffer (J) := Dot (Dot'First); 289 290 else 291 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) := 292 Name_Buffer (J + 1 .. Name_Len); 293 Name_Buffer (J .. J + Dotl - 1) := Dot.all; 294 Name_Len := Name_Len + Dotl - 1; 295 end if; 296 297 J := J + Dotl; 298 299 -- Skip past wide char sequences to avoid messing 300 -- with dot characters that are part of a sequence. 301 302 elsif Name_Buffer (J) = ASCII.ESC 303 or else (Upper_Half_Encoding 304 and then 305 Name_Buffer (J) in Upper_Half_Character) 306 then 307 Skip_Wide (Name_Buffer, J); 308 else 309 J := J + 1; 310 end if; 311 end loop; 312 end if; 313 314 -- Here move result to right if preinsertion before * 315 316 Plen := SFN_Patterns.Table (Pent).Pat'Length; 317 for K in 1 .. Plen loop 318 if C (K) = '*' then 319 if K /= 1 then 320 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) := 321 Name_Buffer (1 .. Name_Len); 322 323 for L in 1 .. K - 1 loop 324 Name_Buffer (L) := C (L); 325 end loop; 326 327 Name_Len := Name_Len + K - 1; 328 end if; 329 330 for L in K + 1 .. Plen loop 331 Name_Len := Name_Len + 1; 332 Name_Buffer (Name_Len) := C (L); 333 end loop; 334 335 exit; 336 end if; 337 end loop; 338 339 -- Execute possible crunch on constructed name. The krunch 340 -- operation excludes any extension that may be present. 341 342 J := Name_Len; 343 while J > 1 loop 344 exit when Name_Buffer (J) = '.'; 345 J := J - 1; 346 end loop; 347 348 -- Case of extension present 349 350 if J > 1 then 351 declare 352 Ext : constant String := Name_Buffer (J .. Name_Len); 353 354 begin 355 -- Remove extension 356 357 Name_Len := J - 1; 358 359 -- Krunch what's left 360 361 Krunch 362 (Name_Buffer, 363 Name_Len, 364 Integer (Maximum_File_Name_Length), 365 Debug_Flag_4); 366 367 -- Replace extension 368 369 Name_Buffer 370 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext; 371 Name_Len := Name_Len + Ext'Length; 372 end; 373 374 -- Case of no extension present, straight krunch on 375 -- the entire file name. 376 377 else 378 Krunch 379 (Name_Buffer, 380 Name_Len, 381 Integer (Maximum_File_Name_Length), 382 Debug_Flag_4); 383 end if; 384 385 Fnam := File_Name_Type (Name_Find); 386 387 -- If we are in the second search of the table, we accept 388 -- the file name without checking, because we know that 389 -- the file does not exist. 390 391 if No_File_Check then 392 return Fnam; 393 394 -- Otherwise we check if the file exists 395 396 else 397 Pname := Find_File (Fnam, Source); 398 399 -- If it does exist, we add it to the mappings and 400 -- return the file name. 401 402 if Pname /= No_File then 403 404 -- Add to mapping, so that we don't do another 405 -- path search in Find_File for this file name 406 -- and, if we use a mapping file, we are ready 407 -- to update it at the end of this compilation 408 -- for the benefit of other compilation processes. 409 410 Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); 411 return Fnam; 412 413 -- If there are only two entries, they are those of 414 -- the default GNAT naming scheme. The file does 415 -- not exist, but there is no point doing the 416 -- second search, because we will end up with the 417 -- same file name. Just return the file name. 418 419 elsif SFN_Patterns.Last = 2 then 420 return Fnam; 421 422 -- The file does not exist, but there may be other 423 -- naming scheme. Keep on searching. 424 425 else 426 Fnam := No_File; 427 end if; 428 end if; 429 end if; 430 431 Pent := Pent + 1; 432 end loop; 433 434 -- If search failed, and was for a subunit, repeat the search 435 -- with Unit_Char_Search reset to 'b', since in the normal case 436 -- we simply treat subunits as bodies. 437 438 if Fnam = No_File and then Unit_Char_Search = 'u' then 439 Unit_Char_Search := 'b'; 440 goto Repeat_Search; 441 end if; 442 443 -- Repeat entire search in No_File_Check mode if necessary 444 445 end loop; 446 447 -- Something is wrong if search fails completely, since the 448 -- default entries should catch all possibilities at this stage. 449 450 raise Program_Error; 451 end; 452 end Get_File_Name; 453 454 ---------------- 455 -- Initialize -- 456 ---------------- 457 458 procedure Initialize is 459 begin 460 SFN_Table.Init; 461 SFN_Patterns.Init; 462 463 -- Add default entries to SFN_Patterns.Table to represent the 464 -- standard default GNAT rules for file name translation. 465 466 SFN_Patterns.Append (New_Val => 467 (Pat => new String'("*.ads"), 468 Typ => 's', 469 Dot => new String'("-"), 470 Cas => All_Lower_Case)); 471 472 SFN_Patterns.Append (New_Val => 473 (Pat => new String'("*.adb"), 474 Typ => 'b', 475 Dot => new String'("-"), 476 Cas => All_Lower_Case)); 477 end Initialize; 478 479 ---------- 480 -- Lock -- 481 ---------- 482 483 procedure Lock is 484 begin 485 SFN_Table.Locked := True; 486 SFN_Table.Release; 487 end Lock; 488 489 ------------------- 490 -- Set_File_Name -- 491 ------------------- 492 493 procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is 494 begin 495 SFN_Table.Increment_Last; 496 SFN_Table.Table (SFN_Table.Last) := (U, F); 497 SFN_HTable.Set (U, SFN_Table.Last); 498 end Set_File_Name; 499 500 --------------------------- 501 -- Set_File_Name_Pattern -- 502 --------------------------- 503 504 procedure Set_File_Name_Pattern 505 (Pat : String_Ptr; 506 Typ : Character; 507 Dot : String_Ptr; 508 Cas : Casing_Type) 509 is 510 L : constant Nat := SFN_Patterns.Last; 511 begin 512 SFN_Patterns.Increment_Last; 513 514 -- Move up the last two entries (the default ones) and then 515 -- put the new entry into the table just before them (we 516 -- always have the default entries be the last ones). 517 518 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L); 519 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1); 520 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas); 521 end Set_File_Name_Pattern; 522 523 -------------- 524 -- SFN_Hash -- 525 -------------- 526 527 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is 528 begin 529 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length); 530 end SFN_Hash; 531 532begin 533 534 -- We call the initialization routine from the package body, so that 535 -- Fname.Init only needs to be called explicitly to reinitialize. 536 537 Fname.UF.Initialize; 538end Fname.UF; 539