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-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. 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 26with Alloc; 27with Debug; use Debug; 28with Fmap; use Fmap; 29with Krunch; 30with Opt; use Opt; 31with Osint; use Osint; 32with Table; 33with Uname; use Uname; 34with Widechar; use Widechar; 35 36with GNAT.HTable; 37 38package body Fname.UF is 39 40 -------------------------------------------------------- 41 -- Declarations for Handling Source_File_Name pragmas -- 42 -------------------------------------------------------- 43 44 type SFN_Entry is record 45 U : Unit_Name_Type; -- Unit name 46 F : File_Name_Type; -- Spec/Body file name 47 Index : Nat; -- Index from SFN pragma (0 if none) 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 is an 76 -- 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 calls to Set_File_Name_Pattern. Note that the first two 94 -- entries are set to represent the standard GNAT rules for file naming. 95 96 ----------------------- 97 -- File_Name_Of_Body -- 98 ----------------------- 99 100 function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is 101 begin 102 Get_Name_String (Name); 103 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b"; 104 Name_Len := Name_Len + 2; 105 return Get_File_Name (Name_Enter, Subunit => False); 106 end File_Name_Of_Body; 107 108 ----------------------- 109 -- File_Name_Of_Spec -- 110 ----------------------- 111 112 function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is 113 begin 114 Get_Name_String (Name); 115 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s"; 116 Name_Len := Name_Len + 2; 117 return Get_File_Name (Name_Enter, Subunit => False); 118 end File_Name_Of_Spec; 119 120 ---------------------------- 121 -- Get_Expected_Unit_Type -- 122 ---------------------------- 123 124 function Get_Expected_Unit_Type 125 (Fname : File_Name_Type) return Expected_Unit_Type 126 is 127 begin 128 -- In syntax checking only mode or in multiple unit per file mode, there 129 -- can be more than one unit in a file, so the file name is not a useful 130 -- guide to the nature of the unit. 131 132 if Operating_Mode = Check_Syntax 133 or else Multiple_Unit_Index /= 0 134 then 135 return Unknown; 136 end if; 137 138 -- Search the file mapping table, if we find an entry for this file we 139 -- know whether it is a spec or a body. 140 141 for J in SFN_Table.First .. SFN_Table.Last loop 142 if Fname = SFN_Table.Table (J).F then 143 if Is_Body_Name (SFN_Table.Table (J).U) then 144 return Expect_Body; 145 else 146 return Expect_Spec; 147 end if; 148 end if; 149 end loop; 150 151 -- If no entry in file naming table, assume .ads/.adb for spec/body and 152 -- return unknown if we have neither of these two cases. 153 154 Get_Name_String (Fname); 155 156 if Name_Len > 4 then 157 if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then 158 return Expect_Spec; 159 elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then 160 return Expect_Body; 161 end if; 162 end if; 163 164 return Unknown; 165 end Get_Expected_Unit_Type; 166 167 ------------------- 168 -- Get_File_Name -- 169 ------------------- 170 171 function Get_File_Name 172 (Uname : Unit_Name_Type; 173 Subunit : Boolean; 174 May_Fail : Boolean := False) return File_Name_Type 175 is 176 Unit_Char : Character; 177 -- Set to 's' or 'b' for spec or body or to 'u' for a subunit 178 179 Unit_Char_Search : Character; 180 -- Same as Unit_Char, except that in the case of 'u' for a subunit, we 181 -- set Unit_Char_Search to 'b' if we do not find a subunit match. 182 183 N : Int; 184 185 Pname : File_Name_Type := No_File; 186 Fname : File_Name_Type := No_File; 187 -- Path name and File name for mapping 188 189 begin 190 -- Null or error name means that some previous error occurred. This is 191 -- an unrecoverable error, so signal it. 192 193 if Uname in Error_Unit_Name_Or_No_Unit_Name then 194 raise Unrecoverable_Error; 195 end if; 196 197 -- Look in the map from unit names to file names 198 199 Fname := Mapped_File_Name (Uname); 200 201 -- If the unit name is already mapped, return the corresponding file 202 -- name from the map. 203 204 if Fname /= No_File then 205 return Fname; 206 end if; 207 208 -- If there is a specific SFN pragma, return the corresponding file name 209 210 N := SFN_HTable.Get (Uname); 211 212 if N /= No_Entry then 213 return SFN_Table.Table (N).F; 214 end if; 215 216 -- Here for the case where the name was not found in the table 217 218 Get_Decoded_Name_String (Uname); 219 220 -- A special fudge, normally we don't have operator symbols present, 221 -- since it is always an error to do so. However, if we do, at this 222 -- stage it has a leading double quote. 223 224 -- What we do in this case is to go back to the undecoded name, which 225 -- is of the form, for example: 226 227 -- Oand%s 228 229 -- and build a file name that looks like: 230 231 -- _and_.ads 232 233 -- which is bit peculiar, but we keep it that way. This means that we 234 -- avoid bombs due to writing a bad file name, and w get expected error 235 -- processing downstream, e.g. a compilation following gnatchop. 236 237 if Name_Buffer (1) = '"' then 238 Get_Name_String (Uname); 239 Name_Len := Name_Len + 1; 240 Name_Buffer (Name_Len) := Name_Buffer (Name_Len - 1); 241 Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2); 242 Name_Buffer (Name_Len - 2) := '_'; 243 Name_Buffer (1) := '_'; 244 end if; 245 246 -- Deal with spec or body suffix 247 248 Unit_Char := Name_Buffer (Name_Len); 249 pragma Assert (Unit_Char = 'b' or else Unit_Char = 's'); 250 pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%'); 251 Name_Len := Name_Len - 2; 252 253 if Subunit then 254 Unit_Char := 'u'; 255 end if; 256 257 -- Now we need to find the proper translation of the name 258 259 declare 260 Uname : constant String (1 .. Name_Len) := 261 Name_Buffer (1 .. Name_Len); 262 263 Pent : Nat; 264 Plen : Natural; 265 Fnam : File_Name_Type := No_File; 266 J : Natural; 267 Dot : String_Ptr; 268 Dotl : Natural; 269 270 Is_Predef : Boolean; 271 -- Set True for predefined file 272 273 function C (N : Natural) return Character; 274 -- Return N'th character of pattern 275 276 function C (N : Natural) return Character is 277 begin 278 return SFN_Patterns.Table (Pent).Pat (N); 279 end C; 280 281 -- Start of search through pattern table 282 283 begin 284 -- Search pattern table to find a matching entry. In the general case 285 -- we do two complete searches. The first time through we stop only 286 -- if a matching file is found, the second time through we accept the 287 -- first match regardless. Note that there will always be a match the 288 -- second time around, because of the default entries at the end of 289 -- the table. 290 291 for No_File_Check in False .. True loop 292 Unit_Char_Search := Unit_Char; 293 294 <<Repeat_Search>> 295 -- The search is repeated with Unit_Char_Search set to b, if an 296 -- initial search for the subunit case fails to find any match. 297 298 Pent := SFN_Patterns.First; 299 while Pent <= SFN_Patterns.Last loop 300 if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then 301 Name_Len := 0; 302 303 -- Determine if we have a predefined file name 304 305 Name_Len := Uname'Length; 306 Name_Buffer (1 .. Name_Len) := Uname; 307 Is_Predef := 308 Is_Predefined_File_Name (Renamings_Included => True); 309 310 -- Found a match, execute the pattern 311 312 Name_Len := Uname'Length; 313 Name_Buffer (1 .. Name_Len) := Uname; 314 315 -- Apply casing, except that we do not do this for the case 316 -- of a predefined library file. For the latter, we always 317 -- use the all lower case name, regardless of the setting. 318 319 if not Is_Predef then 320 Set_Casing (SFN_Patterns.Table (Pent).Cas); 321 end if; 322 323 -- If dot translation required do it 324 325 Dot := SFN_Patterns.Table (Pent).Dot; 326 Dotl := Dot.all'Length; 327 328 if Dot.all /= "." then 329 J := 1; 330 331 while J <= Name_Len loop 332 if Name_Buffer (J) = '.' then 333 334 if Dotl = 1 then 335 Name_Buffer (J) := Dot (Dot'First); 336 337 else 338 Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) := 339 Name_Buffer (J + 1 .. Name_Len); 340 Name_Buffer (J .. J + Dotl - 1) := Dot.all; 341 Name_Len := Name_Len + Dotl - 1; 342 end if; 343 344 J := J + Dotl; 345 346 -- Skip past wide char sequences to avoid messing with 347 -- dot characters that are part of a sequence. 348 349 elsif Name_Buffer (J) = ASCII.ESC 350 or else (Upper_Half_Encoding 351 and then 352 Name_Buffer (J) in Upper_Half_Character) 353 then 354 Skip_Wide (Name_Buffer, J); 355 else 356 J := J + 1; 357 end if; 358 end loop; 359 end if; 360 361 -- Here move result to right if preinsertion before * 362 363 Plen := SFN_Patterns.Table (Pent).Pat'Length; 364 for K in 1 .. Plen loop 365 if C (K) = '*' then 366 if K /= 1 then 367 Name_Buffer (1 + K - 1 .. Name_Len + K - 1) := 368 Name_Buffer (1 .. Name_Len); 369 370 for L in 1 .. K - 1 loop 371 Name_Buffer (L) := C (L); 372 end loop; 373 374 Name_Len := Name_Len + K - 1; 375 end if; 376 377 for L in K + 1 .. Plen loop 378 Name_Len := Name_Len + 1; 379 Name_Buffer (Name_Len) := C (L); 380 end loop; 381 382 exit; 383 end if; 384 end loop; 385 386 -- Execute possible crunch on constructed name. The krunch 387 -- operation excludes any extension that may be present. 388 389 J := Name_Len; 390 while J > 1 loop 391 exit when Name_Buffer (J) = '.'; 392 J := J - 1; 393 end loop; 394 395 -- Case of extension present 396 397 if J > 1 then 398 declare 399 Ext : constant String := Name_Buffer (J .. Name_Len); 400 401 begin 402 -- Remove extension 403 404 Name_Len := J - 1; 405 406 -- Krunch what's left 407 408 Krunch 409 (Name_Buffer, 410 Name_Len, 411 Integer (Maximum_File_Name_Length), 412 Debug_Flag_4); 413 414 -- Replace extension 415 416 Name_Buffer 417 (Name_Len + 1 .. Name_Len + Ext'Length) := Ext; 418 Name_Len := Name_Len + Ext'Length; 419 end; 420 421 -- Case of no extension present, straight krunch on the 422 -- entire file name. 423 424 else 425 Krunch 426 (Name_Buffer, 427 Name_Len, 428 Integer (Maximum_File_Name_Length), 429 Debug_Flag_4); 430 end if; 431 432 Fnam := Name_Find; 433 434 -- If we are in the second search of the table, we accept 435 -- the file name without checking, because we know that the 436 -- file does not exist, except when May_Fail is True, in 437 -- which case we return No_File. 438 439 if No_File_Check then 440 if May_Fail then 441 return No_File; 442 else 443 return Fnam; 444 end if; 445 446 -- Otherwise we check if the file exists 447 448 else 449 Pname := Find_File (Fnam, Source); 450 451 -- If it does exist, we add it to the mappings and return 452 -- the file name. 453 454 if Pname /= No_File then 455 456 -- Add to mapping, so that we don't do another path 457 -- search in Find_File for this file name and, if we 458 -- use a mapping file, we are ready to update it at 459 -- the end of this compilation for the benefit of 460 -- other compilation processes. 461 462 Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); 463 return Fnam; 464 465 -- If there are only two entries, they are those of the 466 -- default GNAT naming scheme. The file does not exist, 467 -- but there is no point doing the second search, because 468 -- we will end up with the same file name. Just return 469 -- the file name, or No_File if May_Fail is True. 470 471 elsif SFN_Patterns.Last = 2 then 472 if May_Fail then 473 return No_File; 474 else 475 return Fnam; 476 end if; 477 478 -- The file does not exist, but there may be other naming 479 -- scheme. Keep on searching. 480 481 else 482 Fnam := No_File; 483 end if; 484 end if; 485 end if; 486 487 Pent := Pent + 1; 488 end loop; 489 490 -- If search failed, and was for a subunit, repeat the search with 491 -- Unit_Char_Search reset to 'b', since in the normal case we 492 -- simply treat subunits as bodies. 493 494 if Fnam = No_File and then Unit_Char_Search = 'u' then 495 Unit_Char_Search := 'b'; 496 goto Repeat_Search; 497 end if; 498 499 -- Repeat entire search in No_File_Check mode if necessary 500 501 end loop; 502 503 -- Something is wrong if search fails completely, since the default 504 -- entries should catch all possibilities at this stage. 505 506 raise Program_Error; 507 end; 508 end Get_File_Name; 509 510 -------------------- 511 -- Get_Unit_Index -- 512 -------------------- 513 514 function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is 515 N : constant Int := SFN_HTable.Get (Uname); 516 begin 517 if N /= No_Entry then 518 return SFN_Table.Table (N).Index; 519 else 520 return 0; 521 end if; 522 end Get_Unit_Index; 523 524 ---------------- 525 -- Initialize -- 526 ---------------- 527 528 procedure Initialize is 529 begin 530 SFN_Table.Init; 531 SFN_Patterns.Init; 532 533 -- Add default entries to SFN_Patterns.Table to represent the standard 534 -- default GNAT rules for file name translation. 535 536 SFN_Patterns.Append (New_Val => 537 (Pat => new String'("*.ads"), 538 Typ => 's', 539 Dot => new String'("-"), 540 Cas => All_Lower_Case)); 541 542 SFN_Patterns.Append (New_Val => 543 (Pat => new String'("*.adb"), 544 Typ => 'b', 545 Dot => new String'("-"), 546 Cas => All_Lower_Case)); 547 end Initialize; 548 549 ---------- 550 -- Lock -- 551 ---------- 552 553 procedure Lock is 554 begin 555 SFN_Table.Locked := True; 556 SFN_Table.Release; 557 end Lock; 558 559 ------------------- 560 -- Set_File_Name -- 561 ------------------- 562 563 procedure Set_File_Name 564 (U : Unit_Name_Type; 565 F : File_Name_Type; 566 Index : Nat) 567 is 568 begin 569 SFN_Table.Increment_Last; 570 SFN_Table.Table (SFN_Table.Last) := (U, F, Index); 571 SFN_HTable.Set (U, SFN_Table.Last); 572 end Set_File_Name; 573 574 --------------------------- 575 -- Set_File_Name_Pattern -- 576 --------------------------- 577 578 procedure Set_File_Name_Pattern 579 (Pat : String_Ptr; 580 Typ : Character; 581 Dot : String_Ptr; 582 Cas : Casing_Type) 583 is 584 L : constant Nat := SFN_Patterns.Last; 585 586 begin 587 SFN_Patterns.Increment_Last; 588 589 -- Move up the last two entries (the default ones) and then put the new 590 -- entry into the table just before them (we always have the default 591 -- entries be the last ones). 592 593 SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L); 594 SFN_Patterns.Table (L) := SFN_Patterns.Table (L - 1); 595 SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas); 596 end Set_File_Name_Pattern; 597 598 -------------- 599 -- SFN_Hash -- 600 -------------- 601 602 function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is 603 begin 604 return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length); 605 end SFN_Hash; 606 607begin 608 609 -- We call the initialization routine from the package body, so that 610 -- Fname.Init only needs to be called explicitly to reinitialize. 611 612 Fname.UF.Initialize; 613end Fname.UF; 614