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