1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . N M S C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-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 Err_Vars; use Err_Vars; 28with Fmap; use Fmap; 29with Hostparm; 30with MLib.Tgt; 31with Namet; use Namet; 32with Osint; use Osint; 33with Output; use Output; 34with MLib.Tgt; use MLib.Tgt; 35with Prj.Com; use Prj.Com; 36with Prj.Env; use Prj.Env; 37with Prj.Err; 38with Prj.Util; use Prj.Util; 39with Sinput.P; 40with Snames; use Snames; 41with Types; use Types; 42 43with Ada.Characters.Handling; use Ada.Characters.Handling; 44with Ada.Strings; use Ada.Strings; 45with Ada.Strings.Fixed; use Ada.Strings.Fixed; 46with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 47 48with GNAT.Case_Util; use GNAT.Case_Util; 49with GNAT.Directory_Operations; use GNAT.Directory_Operations; 50with GNAT.OS_Lib; use GNAT.OS_Lib; 51with GNAT.HTable; 52 53package body Prj.Nmsc is 54 55 Error_Report : Put_Line_Access := null; 56 57 ALI_Suffix : constant String := ".ali"; 58 59 type Name_Location is record 60 Name : Name_Id; 61 Location : Source_Ptr; 62 Found : Boolean := False; 63 end record; 64 -- Information about file names found in string list attribute 65 -- Source_Files or in a source list file, stored in hash table 66 -- Source_Names, used by procedure 67 -- Ada_Check.Get_Path_Names_And_Record_Sources. 68 69 No_Name_Location : constant Name_Location := 70 (Name => No_Name, Location => No_Location, Found => False); 71 72 package Source_Names is new GNAT.HTable.Simple_HTable 73 (Header_Num => Header_Num, 74 Element => Name_Location, 75 No_Element => No_Name_Location, 76 Key => Name_Id, 77 Hash => Hash, 78 Equal => "="); 79 -- Hash table to store file names found in string list attribute 80 -- Source_Files or in a source list file, stored in hash table 81 -- Source_Names, used by procedure 82 -- Ada_Check.Get_Path_Names_And_Record_Sources. 83 84 package Recursive_Dirs is new GNAT.HTable.Simple_HTable 85 (Header_Num => Header_Num, 86 Element => Boolean, 87 No_Element => False, 88 Key => Name_Id, 89 Hash => Hash, 90 Equal => "="); 91 -- Hash table to store recursive source directories, to avoid looking 92 -- several times, and to avoid cycles that may be introduced by symbolic 93 -- links. 94 95 function ALI_File_Name (Source : String) return String; 96 -- Return the ALI file name corresponding to a source. 97 98 procedure Check_Ada_Naming_Scheme 99 (Project : Project_Id; 100 Naming : Naming_Data); 101 -- Check that the package Naming is correct. 102 103 procedure Check_Ada_Name 104 (Name : String; 105 Unit : out Name_Id); 106 -- Check that a name is a valid Ada unit name. 107 108 procedure Error_Msg 109 (Project : Project_Id; 110 Msg : String; 111 Flag_Location : Source_Ptr); 112 -- Output an error message. If Error_Report is null, simply call 113 -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use 114 -- Error_Report. 115 116 procedure Get_Unit 117 (Canonical_File_Name : Name_Id; 118 Naming : Naming_Data; 119 Unit_Name : out Name_Id; 120 Unit_Kind : out Spec_Or_Body; 121 Needs_Pragma : out Boolean); 122 -- Find out, from a file name, the unit name, the unit kind and if a 123 -- specific SFN pragma is needed. If the file name corresponds to no 124 -- unit, then Unit_Name will be No_Name. 125 126 function Is_Illegal_Suffix 127 (Suffix : String; 128 Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean; 129 -- Returns True if the string Suffix cannot be used as 130 -- a spec suffix, a body suffix or a separate suffix. 131 132 procedure Record_Source 133 (File_Name : Name_Id; 134 Path_Name : Name_Id; 135 Project : Project_Id; 136 Data : in out Project_Data; 137 Location : Source_Ptr; 138 Current_Source : in out String_List_Id; 139 Source_Recorded : in out Boolean); 140 -- Put a unit in the list of units of a project, if the file name 141 -- corresponds to a valid unit name. 142 143 procedure Show_Source_Dirs (Project : Project_Id); 144 -- List all the source directories of a project. 145 146 procedure Locate_Directory 147 (Name : Name_Id; 148 Parent : Name_Id; 149 Dir : out Name_Id; 150 Display : out Name_Id); 151 -- Locate a directory. 152 -- Returns No_Name if directory does not exist. 153 154 function Path_Name_Of 155 (File_Name : Name_Id; 156 Directory : Name_Id) return String; 157 -- Returns the path name of a (non project) file. 158 -- Returns an empty string if file cannot be found. 159 160 function Project_Extends 161 (Extending : Project_Id; 162 Extended : Project_Id) return Boolean; 163 -- Returns True if Extending is extending directly or indirectly Extended. 164 165 procedure Check_Naming_Scheme 166 (Data : in out Project_Data; 167 Project : Project_Id); 168 -- Check the naming scheme part of Data 169 170 type Unit_Info is record 171 Kind : Spec_Or_Body; 172 Unit : Name_Id; 173 end record; 174 No_Unit : constant Unit_Info := (Specification, No_Name); 175 176 package Naming_Exceptions is new GNAT.HTable.Simple_HTable 177 (Header_Num => Header_Num, 178 Element => Unit_Info, 179 No_Element => No_Unit, 180 Key => Name_Id, 181 Hash => Hash, 182 Equal => "="); 183 184 function Hash (Unit : Unit_Info) return Header_Num; 185 186 package Reverse_Naming_Exceptions is new GNAT.HTable.Simple_HTable 187 (Header_Num => Header_Num, 188 Element => Name_Id, 189 No_Element => No_Name, 190 Key => Unit_Info, 191 Hash => Hash, 192 Equal => "="); 193 -- A table to check if a unit with an exceptional name will hide 194 -- a source with a file name following the naming convention. 195 196 procedure Prepare_Naming_Exceptions 197 (List : Array_Element_Id; 198 Kind : Spec_Or_Body); 199 -- Prepare the internal hash tables used for checking naming exceptions. 200 -- Insert all elements of List in the tables. 201 202 procedure Free_Naming_Exceptions; 203 -- Free the internal hash tables used for checking naming exceptions 204 205 function Compute_Directory_Last (Dir : String) return Natural; 206 -- Return the index of the last significant character in Dir. This is used 207 -- to avoid duplicates '/' at the end of directory names 208 209 ---------------------------- 210 -- Compute_Directory_Last -- 211 ---------------------------- 212 213 function Compute_Directory_Last (Dir : String) return Natural is 214 begin 215 if Dir'Length > 1 216 and then (Dir (Dir'Last - 1) = Directory_Separator 217 or else Dir (Dir'Last - 1) = '/') 218 then 219 return Dir'Last - 1; 220 else 221 return Dir'Last; 222 end if; 223 end Compute_Directory_Last; 224 225 226 ------------------------------- 227 -- Prepare_Naming_Exceptions -- 228 ------------------------------- 229 230 procedure Prepare_Naming_Exceptions 231 (List : Array_Element_Id; 232 Kind : Spec_Or_Body) 233 is 234 Current : Array_Element_Id := List; 235 Element : Array_Element; 236 237 begin 238 while Current /= No_Array_Element loop 239 Element := Array_Elements.Table (Current); 240 241 if Element.Index /= No_Name then 242 Naming_Exceptions.Set 243 (Element.Value.Value, 244 (Kind => Kind, Unit => Element.Index)); 245 Reverse_Naming_Exceptions.Set 246 ((Kind => Kind, Unit => Element.Index), 247 Element.Value.Value); 248 end if; 249 250 Current := Element.Next; 251 end loop; 252 end Prepare_Naming_Exceptions; 253 254 ---------- 255 -- Hash -- 256 ---------- 257 258 function Hash (Unit : Unit_Info) return Header_Num is 259 begin 260 return Header_Num (Unit.Unit mod 2048); 261 end Hash; 262 263 ---------------------------- 264 -- Free_Naming_Exceptions -- 265 ---------------------------- 266 267 procedure Free_Naming_Exceptions is 268 begin 269 Naming_Exceptions.Reset; 270 Reverse_Naming_Exceptions.Reset; 271 end Free_Naming_Exceptions; 272 273 ------------------------- 274 -- Check_Naming_Scheme -- 275 ------------------------- 276 277 procedure Check_Naming_Scheme 278 (Data : in out Project_Data; 279 Project : Project_Id) 280 is 281 Naming_Id : constant Package_Id := 282 Util.Value_Of (Name_Naming, Data.Decl.Packages); 283 284 Naming : Package_Element; 285 286 procedure Check_Unit_Names (List : Array_Element_Id); 287 -- Check that a list of unit names contains only valid names. 288 289 ---------------------- 290 -- Check_Unit_Names -- 291 ---------------------- 292 293 procedure Check_Unit_Names (List : Array_Element_Id) is 294 Current : Array_Element_Id := List; 295 Element : Array_Element; 296 Unit_Name : Name_Id; 297 298 begin 299 -- Loop through elements of the string list 300 301 while Current /= No_Array_Element loop 302 Element := Array_Elements.Table (Current); 303 304 -- Put file name in canonical case 305 306 Get_Name_String (Element.Value.Value); 307 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 308 Element.Value.Value := Name_Find; 309 310 -- Check that it contains a valid unit name 311 312 Get_Name_String (Element.Index); 313 Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name); 314 315 if Unit_Name = No_Name then 316 Err_Vars.Error_Msg_Name_1 := Element.Index; 317 Error_Msg 318 (Project, 319 "{ is not a valid unit name.", 320 Element.Value.Location); 321 322 else 323 if Current_Verbosity = High then 324 Write_Str (" Unit ("""); 325 Write_Str (Get_Name_String (Unit_Name)); 326 Write_Line (""")"); 327 end if; 328 329 Element.Index := Unit_Name; 330 Array_Elements.Table (Current) := Element; 331 end if; 332 333 Current := Element.Next; 334 end loop; 335 end Check_Unit_Names; 336 337 -- Start of processing for Check_Naming_Scheme 338 339 begin 340 -- If there is a package Naming, we will put in Data.Naming what is in 341 -- this package Naming. 342 343 if Naming_Id /= No_Package then 344 Naming := Packages.Table (Naming_Id); 345 346 if Current_Verbosity = High then 347 Write_Line ("Checking ""Naming"" for Ada."); 348 end if; 349 350 declare 351 Bodies : constant Array_Element_Id := 352 Util.Value_Of (Name_Body, Naming.Decl.Arrays); 353 354 Specs : constant Array_Element_Id := 355 Util.Value_Of (Name_Spec, Naming.Decl.Arrays); 356 357 begin 358 if Bodies /= No_Array_Element then 359 360 -- We have elements in the array Body_Part 361 362 if Current_Verbosity = High then 363 Write_Line ("Found Bodies."); 364 end if; 365 366 Data.Naming.Bodies := Bodies; 367 Check_Unit_Names (Bodies); 368 369 else 370 if Current_Verbosity = High then 371 Write_Line ("No Bodies."); 372 end if; 373 end if; 374 375 if Specs /= No_Array_Element then 376 377 -- We have elements in the array Specs 378 379 if Current_Verbosity = High then 380 Write_Line ("Found Specs."); 381 end if; 382 383 Data.Naming.Specs := Specs; 384 Check_Unit_Names (Specs); 385 386 else 387 if Current_Verbosity = High then 388 Write_Line ("No Specs."); 389 end if; 390 end if; 391 end; 392 393 -- We are now checking if variables Dot_Replacement, Casing, 394 -- Spec_Suffix, Body_Suffix and/or Separate_Suffix 395 -- exist. 396 397 -- For each variable, if it does not exist, we do nothing, 398 -- because we already have the default. 399 400 -- Check Dot_Replacement 401 402 declare 403 Dot_Replacement : constant Variable_Value := 404 Util.Value_Of 405 (Name_Dot_Replacement, 406 Naming.Decl.Attributes); 407 408 begin 409 pragma Assert (Dot_Replacement.Kind = Single, 410 "Dot_Replacement is not a single string"); 411 412 if not Dot_Replacement.Default then 413 Get_Name_String (Dot_Replacement.Value); 414 415 if Name_Len = 0 then 416 Error_Msg 417 (Project, 418 "Dot_Replacement cannot be empty", 419 Dot_Replacement.Location); 420 421 else 422 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 423 Data.Naming.Dot_Replacement := Name_Find; 424 Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location; 425 end if; 426 end if; 427 end; 428 429 if Current_Verbosity = High then 430 Write_Str (" Dot_Replacement = """); 431 Write_Str (Get_Name_String (Data.Naming.Dot_Replacement)); 432 Write_Char ('"'); 433 Write_Eol; 434 end if; 435 436 -- Check Casing 437 438 declare 439 Casing_String : constant Variable_Value := 440 Util.Value_Of 441 (Name_Casing, Naming.Decl.Attributes); 442 443 begin 444 pragma Assert (Casing_String.Kind = Single, 445 "Casing is not a single string"); 446 447 if not Casing_String.Default then 448 declare 449 Casing_Image : constant String := 450 Get_Name_String (Casing_String.Value); 451 begin 452 declare 453 Casing : constant Casing_Type := Value (Casing_Image); 454 begin 455 Data.Naming.Casing := Casing; 456 end; 457 458 exception 459 when Constraint_Error => 460 if Casing_Image'Length = 0 then 461 Error_Msg 462 (Project, 463 "Casing cannot be an empty string", 464 Casing_String.Location); 465 466 else 467 Name_Len := Casing_Image'Length; 468 Name_Buffer (1 .. Name_Len) := Casing_Image; 469 Err_Vars.Error_Msg_Name_1 := Name_Find; 470 Error_Msg 471 (Project, 472 "{ is not a correct Casing", 473 Casing_String.Location); 474 end if; 475 end; 476 end if; 477 end; 478 479 if Current_Verbosity = High then 480 Write_Str (" Casing = "); 481 Write_Str (Image (Data.Naming.Casing)); 482 Write_Char ('.'); 483 Write_Eol; 484 end if; 485 486 -- Check Spec_Suffix 487 488 declare 489 Ada_Spec_Suffix : constant Variable_Value := 490 Prj.Util.Value_Of 491 (Index => Name_Ada, 492 In_Array => Data.Naming.Spec_Suffix); 493 494 begin 495 if Ada_Spec_Suffix.Kind = Single 496 and then Get_Name_String (Ada_Spec_Suffix.Value) /= "" 497 then 498 Data.Naming.Current_Spec_Suffix := Ada_Spec_Suffix.Value; 499 Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location; 500 501 else 502 Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; 503 end if; 504 end; 505 506 if Current_Verbosity = High then 507 Write_Str (" Spec_Suffix = """); 508 Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix)); 509 Write_Char ('"'); 510 Write_Eol; 511 end if; 512 513 -- Check Body_Suffix 514 515 declare 516 Ada_Body_Suffix : constant Variable_Value := 517 Prj.Util.Value_Of 518 (Index => Name_Ada, 519 In_Array => Data.Naming.Body_Suffix); 520 521 begin 522 if Ada_Body_Suffix.Kind = Single 523 and then Get_Name_String (Ada_Body_Suffix.Value) /= "" 524 then 525 Data.Naming.Current_Body_Suffix := Ada_Body_Suffix.Value; 526 Data.Naming.Body_Suffix_Loc := Ada_Body_Suffix.Location; 527 528 else 529 Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; 530 end if; 531 end; 532 533 if Current_Verbosity = High then 534 Write_Str (" Body_Suffix = """); 535 Write_Str (Get_Name_String (Data.Naming.Current_Body_Suffix)); 536 Write_Char ('"'); 537 Write_Eol; 538 end if; 539 540 -- Check Separate_Suffix 541 542 declare 543 Ada_Sep_Suffix : constant Variable_Value := 544 Prj.Util.Value_Of 545 (Variable_Name => Name_Separate_Suffix, 546 In_Variables => Naming.Decl.Attributes); 547 548 begin 549 if Ada_Sep_Suffix.Default then 550 Data.Naming.Separate_Suffix := 551 Data.Naming.Current_Body_Suffix; 552 553 else 554 if Get_Name_String (Ada_Sep_Suffix.Value) = "" then 555 Error_Msg 556 (Project, 557 "Separate_Suffix cannot be empty", 558 Ada_Sep_Suffix.Location); 559 560 else 561 Data.Naming.Separate_Suffix := Ada_Sep_Suffix.Value; 562 Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location; 563 end if; 564 end if; 565 end; 566 567 if Current_Verbosity = High then 568 Write_Str (" Separate_Suffix = """); 569 Write_Str (Get_Name_String (Data.Naming.Separate_Suffix)); 570 Write_Char ('"'); 571 Write_Eol; 572 end if; 573 574 -- Check if Data.Naming is valid 575 576 Check_Ada_Naming_Scheme (Project, Data.Naming); 577 578 else 579 Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix; 580 Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix; 581 Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix; 582 end if; 583 end Check_Naming_Scheme; 584 585 --------------- 586 -- Ada_Check -- 587 --------------- 588 589 procedure Ada_Check 590 (Project : Project_Id; 591 Report_Error : Put_Line_Access) 592 is 593 Data : Project_Data; 594 Languages : Variable_Value := Nil_Variable_Value; 595 596 Extending : Boolean := False; 597 598 function Check_Project (P : Project_Id) return Boolean; 599 -- Returns True if P is Project or a project extended by Project 600 601 procedure Find_Sources; 602 -- Find all the sources in all of the source directories 603 -- of a project. 604 605 procedure Get_Path_Names_And_Record_Sources; 606 -- Find the path names of the source files in the Source_Names table 607 -- in the source directories and record those that are Ada sources. 608 609 procedure Get_Sources_From_File 610 (Path : String; 611 Location : Source_Ptr); 612 -- Get the sources of a project from a text file 613 614 procedure Warn_If_Not_Sources 615 (Conventions : Array_Element_Id; 616 Specs : Boolean); 617 -- Check that individual naming conventions apply to immediate 618 -- sources of the project; if not, issue a warning. 619 620 ------------------- 621 -- Check_Project -- 622 ------------------- 623 624 function Check_Project (P : Project_Id) return Boolean is 625 begin 626 if P = Project then 627 return True; 628 elsif Extending then 629 declare 630 Data : Project_Data := Projects.Table (Project); 631 632 begin 633 while Data.Extends /= No_Project loop 634 if P = Data.Extends then 635 return True; 636 end if; 637 638 Data := Projects.Table (Data.Extends); 639 end loop; 640 end; 641 end if; 642 643 return False; 644 end Check_Project; 645 646 ------------------ 647 -- Find_Sources -- 648 ------------------ 649 650 procedure Find_Sources is 651 Source_Dir : String_List_Id := Data.Source_Dirs; 652 Element : String_Element; 653 Dir : Dir_Type; 654 Current_Source : String_List_Id := Nil_String; 655 Source_Recorded : Boolean := False; 656 657 begin 658 if Current_Verbosity = High then 659 Write_Line ("Looking for sources:"); 660 end if; 661 662 -- For each subdirectory 663 664 while Source_Dir /= Nil_String loop 665 begin 666 Source_Recorded := False; 667 Element := String_Elements.Table (Source_Dir); 668 if Element.Value /= No_Name then 669 declare 670 Source_Directory : constant String := 671 Get_Name_String (Element.Value); 672 673 begin 674 if Current_Verbosity = High then 675 Write_Str ("Source_Dir = "); 676 Write_Line (Source_Directory); 677 end if; 678 679 -- We look to every entry in the source directory 680 681 Open (Dir, Source_Directory); 682 683 -- Canonical_Case_File_Name (Source_Directory); 684 685 loop 686 Read (Dir, Name_Buffer, Name_Len); 687 688 if Current_Verbosity = High then 689 Write_Str (" Checking "); 690 Write_Line (Name_Buffer (1 .. Name_Len)); 691 end if; 692 693 exit when Name_Len = 0; 694 695 -- Canonical_Case_File_Name 696 -- (Name_Buffer (1 .. Name_Len)); 697 698 declare 699 File_Name : constant Name_Id := Name_Find; 700 Dir : constant String := 701 Source_Directory & 702 Directory_Separator; 703 Dir_Last : constant Natural := 704 Compute_Directory_Last (Dir); 705 Path : constant String := 706 Normalize_Pathname 707 (Name => Name_Buffer (1 .. Name_Len), 708 Directory => Dir (Dir'First .. Dir_Last)); 709 Path_Name : Name_Id; 710 711 begin 712 if Is_Regular_File (Path) then 713 714 Name_Len := Path'Length; 715 Name_Buffer (1 .. Name_Len) := Path; 716 Path_Name := Name_Find; 717 718 -- We attempt to register it as a source. 719 -- However, there is no error if the file 720 -- does not contain a valid source. 721 -- But there is an error if we have a 722 -- duplicate unit name. 723 724 Record_Source 725 (File_Name => File_Name, 726 Path_Name => Path_Name, 727 Project => Project, 728 Data => Data, 729 Location => No_Location, 730 Current_Source => Current_Source, 731 Source_Recorded => Source_Recorded); 732 end if; 733 end; 734 end loop; 735 736 Close (Dir); 737 end; 738 end if; 739 740 exception 741 when Directory_Error => 742 null; 743 end; 744 745 if Source_Recorded then 746 String_Elements.Table (Source_Dir).Flag := True; 747 end if; 748 749 Source_Dir := Element.Next; 750 end loop; 751 752 if Current_Verbosity = High then 753 Write_Line ("end Looking for sources."); 754 end if; 755 756 -- If we have looked for sources and found none, then 757 -- it is an error, except if it is an extending project. 758 -- If a non extending project is not supposed to contain 759 -- any source, then we never call Find_Sources. 760 761 if Data.Extends = No_Project 762 and then Current_Source = Nil_String 763 then 764 Error_Msg 765 (Project, 766 "there are no Ada sources in this project", 767 Data.Location); 768 end if; 769 end Find_Sources; 770 771 --------------------------------------- 772 -- Get_Path_Names_And_Record_Sources -- 773 --------------------------------------- 774 775 procedure Get_Path_Names_And_Record_Sources is 776 Source_Dir : String_List_Id := Data.Source_Dirs; 777 Element : String_Element; 778 Path : Name_Id; 779 780 Dir : Dir_Type; 781 Name : Name_Id; 782 Canonical_Name : Name_Id; 783 Name_Str : String (1 .. 1_024); 784 Last : Natural := 0; 785 NL : Name_Location; 786 787 Current_Source : String_List_Id := Nil_String; 788 789 First_Error : Boolean := True; 790 791 Source_Recorded : Boolean := False; 792 793 begin 794 -- We look in all source directories for this file name 795 796 while Source_Dir /= Nil_String loop 797 Source_Recorded := False; 798 Element := String_Elements.Table (Source_Dir); 799 800 declare 801 Dir_Path : constant String := Get_Name_String (Element.Value); 802 begin 803 if Current_Verbosity = High then 804 Write_Str ("checking directory """); 805 Write_Str (Dir_Path); 806 Write_Line (""""); 807 end if; 808 809 Open (Dir, Dir_Path); 810 811 loop 812 Read (Dir, Name_Str, Last); 813 exit when Last = 0; 814 Name_Len := Last; 815 Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); 816 Name := Name_Find; 817 Canonical_Case_File_Name (Name_Str (1 .. Last)); 818 Name_Len := Last; 819 Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); 820 Canonical_Name := Name_Find; 821 NL := Source_Names.Get (Canonical_Name); 822 823 if NL /= No_Name_Location and then not NL.Found then 824 NL.Found := True; 825 Source_Names.Set (Canonical_Name, NL); 826 Name_Len := Dir_Path'Length; 827 Name_Buffer (1 .. Name_Len) := Dir_Path; 828 Add_Char_To_Name_Buffer (Directory_Separator); 829 Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); 830 Path := Name_Find; 831 832 if Current_Verbosity = High then 833 Write_Str (" found "); 834 Write_Line (Get_Name_String (Name)); 835 end if; 836 837 -- Register the source if it is an Ada compilation unit.. 838 839 Record_Source 840 (File_Name => Name, 841 Path_Name => Path, 842 Project => Project, 843 Data => Data, 844 Location => NL.Location, 845 Current_Source => Current_Source, 846 Source_Recorded => Source_Recorded); 847 end if; 848 end loop; 849 850 Close (Dir); 851 end; 852 853 if Source_Recorded then 854 String_Elements.Table (Source_Dir).Flag := True; 855 end if; 856 857 Source_Dir := Element.Next; 858 end loop; 859 860 -- It is an error if a source file name in a source list or 861 -- in a source list file is not found. 862 863 NL := Source_Names.Get_First; 864 865 while NL /= No_Name_Location loop 866 if not NL.Found then 867 Err_Vars.Error_Msg_Name_1 := NL.Name; 868 869 if First_Error then 870 Error_Msg 871 (Project, 872 "source file { cannot be found", 873 NL.Location); 874 First_Error := False; 875 876 else 877 Error_Msg 878 (Project, 879 "\source file { cannot be found", 880 NL.Location); 881 end if; 882 end if; 883 884 NL := Source_Names.Get_Next; 885 end loop; 886 end Get_Path_Names_And_Record_Sources; 887 888 --------------------------- 889 -- Get_Sources_From_File -- 890 --------------------------- 891 892 procedure Get_Sources_From_File 893 (Path : String; 894 Location : Source_Ptr) 895 is 896 File : Prj.Util.Text_File; 897 Line : String (1 .. 250); 898 Last : Natural; 899 Source_Name : Name_Id; 900 901 begin 902 if Current_Verbosity = High then 903 Write_Str ("Opening """); 904 Write_Str (Path); 905 Write_Line ("""."); 906 end if; 907 908 -- We open the file 909 910 Prj.Util.Open (File, Path); 911 912 if not Prj.Util.Is_Valid (File) then 913 Error_Msg (Project, "file does not exist", Location); 914 else 915 Source_Names.Reset; 916 917 while not Prj.Util.End_Of_File (File) loop 918 Prj.Util.Get_Line (File, Line, Last); 919 920 -- If the line is not empty and does not start with "--", 921 -- then it should contain a file name. However, if the 922 -- file name does not exist, it may be for another language 923 -- and we don't fail. 924 925 if Last /= 0 926 and then (Last = 1 or else Line (1 .. 2) /= "--") 927 then 928 Name_Len := Last; 929 Name_Buffer (1 .. Name_Len) := Line (1 .. Last); 930 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 931 Source_Name := Name_Find; 932 Source_Names.Set 933 (K => Source_Name, 934 E => 935 (Name => Source_Name, 936 Location => Location, 937 Found => False)); 938 end if; 939 end loop; 940 941 Prj.Util.Close (File); 942 943 end if; 944 945 Get_Path_Names_And_Record_Sources; 946 947 -- We should have found at least one source. 948 -- If not, report an error. 949 950 if Data.Sources = Nil_String then 951 Error_Msg (Project, 952 "there are no Ada sources in this project", 953 Location); 954 end if; 955 end Get_Sources_From_File; 956 957 ------------------------- 958 -- Warn_If_Not_Sources -- 959 ------------------------- 960 961 procedure Warn_If_Not_Sources 962 (Conventions : Array_Element_Id; 963 Specs : Boolean) 964 is 965 Conv : Array_Element_Id := Conventions; 966 Unit : Name_Id; 967 The_Unit_Id : Unit_Id; 968 The_Unit_Data : Unit_Data; 969 Location : Source_Ptr; 970 971 begin 972 while Conv /= No_Array_Element loop 973 Unit := Array_Elements.Table (Conv).Index; 974 Error_Msg_Name_1 := Unit; 975 Get_Name_String (Unit); 976 To_Lower (Name_Buffer (1 .. Name_Len)); 977 Unit := Name_Find; 978 The_Unit_Id := Units_Htable.Get (Unit); 979 Location := Array_Elements.Table (Conv).Value.Location; 980 981 if The_Unit_Id = Prj.Com.No_Unit then 982 Error_Msg 983 (Project, 984 "?unknown unit {", 985 Location); 986 987 else 988 The_Unit_Data := Units.Table (The_Unit_Id); 989 990 if Specs then 991 if not Check_Project 992 (The_Unit_Data.File_Names (Specification).Project) 993 then 994 Error_Msg 995 (Project, 996 "?unit{ has no spec in this project", 997 Location); 998 end if; 999 1000 else 1001 if not Check_Project 1002 (The_Unit_Data.File_Names (Com.Body_Part).Project) 1003 then 1004 Error_Msg 1005 (Project, 1006 "?unit{ has no body in this project", 1007 Location); 1008 end if; 1009 end if; 1010 end if; 1011 1012 Conv := Array_Elements.Table (Conv).Next; 1013 end loop; 1014 end Warn_If_Not_Sources; 1015 1016 -- Start of processing for Ada_Check 1017 1018 begin 1019 Language_Independent_Check (Project, Report_Error); 1020 1021 Error_Report := Report_Error; 1022 1023 Data := Projects.Table (Project); 1024 Extending := Data.Extends /= No_Project; 1025 Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes); 1026 1027 Data.Naming.Current_Language := Name_Ada; 1028 Data.Sources_Present := Data.Source_Dirs /= Nil_String; 1029 1030 if not Languages.Default then 1031 declare 1032 Current : String_List_Id := Languages.Values; 1033 Element : String_Element; 1034 Ada_Found : Boolean := False; 1035 1036 begin 1037 Look_For_Ada : while Current /= Nil_String loop 1038 Element := String_Elements.Table (Current); 1039 Get_Name_String (Element.Value); 1040 To_Lower (Name_Buffer (1 .. Name_Len)); 1041 1042 if Name_Buffer (1 .. Name_Len) = "ada" then 1043 Ada_Found := True; 1044 exit Look_For_Ada; 1045 end if; 1046 1047 Current := Element.Next; 1048 end loop Look_For_Ada; 1049 1050 if not Ada_Found then 1051 1052 -- Mark the project file as having no sources for Ada 1053 1054 Data.Sources_Present := False; 1055 end if; 1056 end; 1057 end if; 1058 1059 Check_Naming_Scheme (Data, Project); 1060 1061 Prepare_Naming_Exceptions (Data.Naming.Bodies, Body_Part); 1062 Prepare_Naming_Exceptions (Data.Naming.Specs, Specification); 1063 1064 -- If we have source directories, then find the sources 1065 1066 if Data.Sources_Present then 1067 if Data.Source_Dirs = Nil_String then 1068 Data.Sources_Present := False; 1069 1070 else 1071 declare 1072 Sources : constant Variable_Value := 1073 Util.Value_Of 1074 (Name_Source_Files, 1075 Data.Decl.Attributes); 1076 1077 Source_List_File : constant Variable_Value := 1078 Util.Value_Of 1079 (Name_Source_List_File, 1080 Data.Decl.Attributes); 1081 1082 Locally_Removed : constant Variable_Value := 1083 Util.Value_Of 1084 (Name_Locally_Removed_Files, 1085 Data.Decl.Attributes); 1086 1087 1088 begin 1089 pragma Assert 1090 (Sources.Kind = List, 1091 "Source_Files is not a list"); 1092 1093 pragma Assert 1094 (Source_List_File.Kind = Single, 1095 "Source_List_File is not a single string"); 1096 1097 if not Sources.Default then 1098 if not Source_List_File.Default then 1099 Error_Msg 1100 (Project, 1101 "?both variables source_files and " & 1102 "source_list_file are present", 1103 Source_List_File.Location); 1104 end if; 1105 1106 -- Sources is a list of file names 1107 1108 declare 1109 Current : String_List_Id := Sources.Values; 1110 Element : String_Element; 1111 Location : Source_Ptr; 1112 Name : Name_Id; 1113 1114 begin 1115 Source_Names.Reset; 1116 1117 Data.Sources_Present := Current /= Nil_String; 1118 1119 while Current /= Nil_String loop 1120 Element := String_Elements.Table (Current); 1121 Get_Name_String (Element.Value); 1122 Canonical_Case_File_Name 1123 (Name_Buffer (1 .. Name_Len)); 1124 Name := Name_Find; 1125 1126 -- If the element has no location, then use the 1127 -- location of Sources to report possible errors. 1128 1129 if Element.Location = No_Location then 1130 Location := Sources.Location; 1131 1132 else 1133 Location := Element.Location; 1134 end if; 1135 1136 Source_Names.Set 1137 (K => Name, 1138 E => 1139 (Name => Name, 1140 Location => Location, 1141 Found => False)); 1142 1143 Current := Element.Next; 1144 end loop; 1145 1146 Get_Path_Names_And_Record_Sources; 1147 end; 1148 1149 -- No source_files specified. 1150 -- We check Source_List_File has been specified. 1151 1152 elsif not Source_List_File.Default then 1153 1154 -- Source_List_File is the name of the file 1155 -- that contains the source file names 1156 1157 declare 1158 Source_File_Path_Name : constant String := 1159 Path_Name_Of 1160 (Source_List_File.Value, 1161 Data.Directory); 1162 1163 begin 1164 if Source_File_Path_Name'Length = 0 then 1165 Err_Vars.Error_Msg_Name_1 := Source_List_File.Value; 1166 Error_Msg 1167 (Project, 1168 "file with sources { does not exist", 1169 Source_List_File.Location); 1170 1171 else 1172 Get_Sources_From_File 1173 (Source_File_Path_Name, 1174 Source_List_File.Location); 1175 end if; 1176 end; 1177 1178 else 1179 -- Neither Source_Files nor Source_List_File has been 1180 -- specified. 1181 -- Find all the files that satisfy 1182 -- the naming scheme in all the source directories. 1183 1184 Find_Sources; 1185 end if; 1186 1187 -- If there are sources that are locally removed, mark them as 1188 -- such in the Units table. 1189 1190 if not Locally_Removed.Default then 1191 -- Sources can be locally removed only in extending 1192 -- project files. 1193 1194 if Data.Extends = No_Project then 1195 Error_Msg 1196 (Project, 1197 "Locally_Removed_Files can only be used " & 1198 "in an extending project file", 1199 Locally_Removed.Location); 1200 1201 else 1202 declare 1203 Current : String_List_Id := 1204 Locally_Removed.Values; 1205 Element : String_Element; 1206 Location : Source_Ptr; 1207 OK : Boolean; 1208 Unit : Unit_Data; 1209 Name : Name_Id; 1210 Extended : Project_Id; 1211 1212 begin 1213 while Current /= Nil_String loop 1214 Element := String_Elements.Table (Current); 1215 Get_Name_String (Element.Value); 1216 Canonical_Case_File_Name 1217 (Name_Buffer (1 .. Name_Len)); 1218 Name := Name_Find; 1219 1220 -- If the element has no location, then use the 1221 -- location of Locally_Removed to report 1222 -- possible errors. 1223 1224 if Element.Location = No_Location then 1225 Location := Locally_Removed.Location; 1226 1227 else 1228 Location := Element.Location; 1229 end if; 1230 1231 OK := False; 1232 1233 for Index in 1 .. Units.Last loop 1234 Unit := Units.Table (Index); 1235 1236 if 1237 Unit.File_Names (Specification).Name = Name 1238 then 1239 OK := True; 1240 1241 -- Check that this is from a project that 1242 -- the current project extends, but not the 1243 -- current project. 1244 1245 Extended := Unit.File_Names 1246 (Specification).Project; 1247 1248 if Extended = Project then 1249 Error_Msg 1250 (Project, 1251 "cannot remove a source " & 1252 "of the same project", 1253 Location); 1254 1255 elsif 1256 Project_Extends (Project, Extended) 1257 then 1258 Unit.File_Names 1259 (Specification).Path := Slash; 1260 Unit.File_Names 1261 (Specification).Needs_Pragma := False; 1262 Units.Table (Index) := Unit; 1263 Add_Forbidden_File_Name 1264 (Unit.File_Names (Specification).Name); 1265 exit; 1266 1267 else 1268 Error_Msg 1269 (Project, 1270 "cannot remove a source from " & 1271 "another project", 1272 Location); 1273 end if; 1274 1275 elsif 1276 Unit.File_Names (Body_Part).Name = Name 1277 then 1278 OK := True; 1279 1280 -- Check that this is from a project that 1281 -- the current project extends, but not the 1282 -- current project. 1283 1284 Extended := Unit.File_Names 1285 (Body_Part).Project; 1286 1287 if Extended = Project then 1288 Error_Msg 1289 (Project, 1290 "cannot remove a source " & 1291 "of the same project", 1292 Location); 1293 1294 elsif 1295 Project_Extends (Project, Extended) 1296 then 1297 Unit.File_Names (Body_Part).Path := Slash; 1298 Unit.File_Names (Body_Part).Needs_Pragma 1299 := False; 1300 Units.Table (Index) := Unit; 1301 Add_Forbidden_File_Name 1302 (Unit.File_Names (Body_Part).Name); 1303 exit; 1304 end if; 1305 1306 end if; 1307 end loop; 1308 1309 if not OK then 1310 Err_Vars.Error_Msg_Name_1 := Name; 1311 Error_Msg (Project, "unknown file {", Location); 1312 end if; 1313 1314 Current := Element.Next; 1315 end loop; 1316 end; 1317 end if; 1318 end if; 1319 end; 1320 end if; 1321 end if; 1322 1323 if Data.Sources_Present then 1324 1325 -- Check that all individual naming conventions apply to 1326 -- sources of this project file. 1327 1328 Warn_If_Not_Sources (Data.Naming.Bodies, Specs => False); 1329 Warn_If_Not_Sources (Data.Naming.Specs, Specs => True); 1330 end if; 1331 1332 -- If it is a library project file, check if it is a standalone library 1333 1334 if Data.Library then 1335 Standalone_Library : declare 1336 Lib_Interfaces : constant Prj.Variable_Value := 1337 Prj.Util.Value_Of 1338 (Snames.Name_Library_Interface, 1339 Data.Decl.Attributes); 1340 Lib_Auto_Init : constant Prj.Variable_Value := 1341 Prj.Util.Value_Of 1342 (Snames.Name_Library_Auto_Init, 1343 Data.Decl.Attributes); 1344 1345 Lib_Src_Dir : constant Prj.Variable_Value := 1346 Prj.Util.Value_Of 1347 (Snames.Name_Library_Src_Dir, 1348 Data.Decl.Attributes); 1349 1350 Lib_Symbol_File : constant Prj.Variable_Value := 1351 Prj.Util.Value_Of 1352 (Snames.Name_Library_Symbol_File, 1353 Data.Decl.Attributes); 1354 1355 Lib_Symbol_Policy : constant Prj.Variable_Value := 1356 Prj.Util.Value_Of 1357 (Snames.Name_Library_Symbol_Policy, 1358 Data.Decl.Attributes); 1359 1360 Lib_Ref_Symbol_File : constant Prj.Variable_Value := 1361 Prj.Util.Value_Of 1362 (Snames.Name_Library_Reference_Symbol_File, 1363 Data.Decl.Attributes); 1364 1365 Auto_Init_Supported : constant Boolean := 1366 MLib.Tgt. 1367 Standalone_Library_Auto_Init_Is_Supported; 1368 1369 OK : Boolean := True; 1370 1371 begin 1372 pragma Assert (Lib_Interfaces.Kind = List); 1373 1374 -- It is a stand-alone library project file if attribute 1375 -- Library_Interface is defined. 1376 1377 if not Lib_Interfaces.Default then 1378 declare 1379 Interfaces : String_List_Id := Lib_Interfaces.Values; 1380 Interface_ALIs : String_List_Id := Nil_String; 1381 Unit : Name_Id; 1382 The_Unit_Id : Unit_Id; 1383 The_Unit_Data : Unit_Data; 1384 1385 procedure Add_ALI_For (Source : Name_Id); 1386 -- Add an ALI file name to the list of Interface ALIs 1387 1388 ----------------- 1389 -- Add_ALI_For -- 1390 ----------------- 1391 1392 procedure Add_ALI_For (Source : Name_Id) is 1393 begin 1394 Get_Name_String (Source); 1395 1396 declare 1397 ALI : constant String := 1398 ALI_File_Name (Name_Buffer (1 .. Name_Len)); 1399 ALI_Name_Id : Name_Id; 1400 begin 1401 Name_Len := ALI'Length; 1402 Name_Buffer (1 .. Name_Len) := ALI; 1403 ALI_Name_Id := Name_Find; 1404 1405 String_Elements.Increment_Last; 1406 String_Elements.Table (String_Elements.Last) := 1407 (Value => ALI_Name_Id, 1408 Display_Value => No_Name, 1409 Location => String_Elements.Table 1410 (Interfaces).Location, 1411 Flag => False, 1412 Next => Interface_ALIs); 1413 Interface_ALIs := String_Elements.Last; 1414 end; 1415 end Add_ALI_For; 1416 1417 begin 1418 Data.Standalone_Library := True; 1419 1420 -- Library_Interface cannot be an empty list 1421 1422 if Interfaces = Nil_String then 1423 Error_Msg 1424 (Project, 1425 "Library_Interface cannot be an empty list", 1426 Lib_Interfaces.Location); 1427 end if; 1428 1429 -- Process each unit name specified in the attribute 1430 -- Library_Interface. 1431 1432 while Interfaces /= Nil_String loop 1433 Get_Name_String 1434 (String_Elements.Table (Interfaces).Value); 1435 To_Lower (Name_Buffer (1 .. Name_Len)); 1436 1437 if Name_Len = 0 then 1438 Error_Msg 1439 (Project, 1440 "an interface cannot be an empty string", 1441 String_Elements.Table (Interfaces).Location); 1442 1443 else 1444 Unit := Name_Find; 1445 Error_Msg_Name_1 := Unit; 1446 The_Unit_Id := Units_Htable.Get (Unit); 1447 1448 if The_Unit_Id = Prj.Com.No_Unit then 1449 Error_Msg 1450 (Project, 1451 "unknown unit {", 1452 String_Elements.Table (Interfaces).Location); 1453 1454 else 1455 -- Check that the unit is part of the project 1456 1457 The_Unit_Data := Units.Table (The_Unit_Id); 1458 1459 if The_Unit_Data.File_Names 1460 (Com.Body_Part).Name /= No_Name 1461 and then The_Unit_Data.File_Names 1462 (Com.Body_Part).Path /= Slash 1463 then 1464 if Check_Project 1465 (The_Unit_Data.File_Names (Body_Part).Project) 1466 then 1467 -- There is a body for this unit. 1468 -- If there is no spec, we need to check 1469 -- that it is not a subunit. 1470 1471 if The_Unit_Data.File_Names 1472 (Specification).Name = No_Name 1473 then 1474 declare 1475 Src_Ind : Source_File_Index; 1476 1477 begin 1478 Src_Ind := Sinput.P.Load_Project_File 1479 (Get_Name_String 1480 (The_Unit_Data.File_Names 1481 (Body_Part).Path)); 1482 1483 if Sinput.P.Source_File_Is_Subunit 1484 (Src_Ind) 1485 then 1486 Error_Msg 1487 (Project, 1488 "{ is a subunit; " & 1489 "it cannot be an interface", 1490 String_Elements.Table 1491 (Interfaces).Location); 1492 end if; 1493 end; 1494 end if; 1495 1496 -- The unit is not a subunit, so we add 1497 -- to the Interface ALIs the ALI file 1498 -- corresponding to the body. 1499 1500 Add_ALI_For 1501 (The_Unit_Data.File_Names (Body_Part).Name); 1502 1503 else 1504 Error_Msg 1505 (Project, 1506 "{ is not an unit of this project", 1507 String_Elements.Table 1508 (Interfaces).Location); 1509 end if; 1510 1511 elsif The_Unit_Data.File_Names 1512 (Com.Specification).Name /= No_Name 1513 and then The_Unit_Data.File_Names 1514 (Com.Specification).Path /= Slash 1515 and then Check_Project 1516 (The_Unit_Data.File_Names 1517 (Specification).Project) 1518 1519 then 1520 -- The unit is part of the project, it has 1521 -- a spec, but no body. We add to the Interface 1522 -- ALIs the ALI file corresponding to the spec. 1523 1524 Add_ALI_For 1525 (The_Unit_Data.File_Names (Specification).Name); 1526 1527 else 1528 Error_Msg 1529 (Project, 1530 "{ is not an unit of this project", 1531 String_Elements.Table (Interfaces).Location); 1532 end if; 1533 end if; 1534 1535 end if; 1536 1537 Interfaces := String_Elements.Table (Interfaces).Next; 1538 end loop; 1539 1540 -- Put the list of Interface ALIs in the project data 1541 1542 Data.Lib_Interface_ALIs := Interface_ALIs; 1543 1544 -- Check value of attribute Library_Auto_Init and set 1545 -- Lib_Auto_Init accordingly. 1546 1547 if Lib_Auto_Init.Default then 1548 -- If no attribute Library_Auto_Init is declared, then 1549 -- set auto init only if it is supported. 1550 1551 Data.Lib_Auto_Init := Auto_Init_Supported; 1552 1553 else 1554 Get_Name_String (Lib_Auto_Init.Value); 1555 To_Lower (Name_Buffer (1 .. Name_Len)); 1556 1557 if Name_Buffer (1 .. Name_Len) = "false" then 1558 Data.Lib_Auto_Init := False; 1559 1560 elsif Name_Buffer (1 .. Name_Len) = "true" then 1561 if Auto_Init_Supported then 1562 Data.Lib_Auto_Init := True; 1563 1564 else 1565 -- Library_Auto_Init cannot be "true" if auto init 1566 -- is not supported 1567 1568 Error_Msg 1569 (Project, 1570 "library auto init not supported " & 1571 "on this platform", 1572 Lib_Auto_Init.Location); 1573 end if; 1574 1575 else 1576 Error_Msg 1577 (Project, 1578 "invalid value for attribute Library_Auto_Init", 1579 Lib_Auto_Init.Location); 1580 end if; 1581 end if; 1582 end; 1583 1584 -- If attribute Library_Src_Dir is defined and not the 1585 -- empty string, check if the directory exist and is not 1586 -- the object directory or one of the source directories. 1587 -- This is the directory where copies of the interface 1588 -- sources will be copied. Note that this directory may be 1589 -- the library directory. 1590 1591 if Lib_Src_Dir.Value /= Empty_String then 1592 declare 1593 Dir_Id : constant Name_Id := Lib_Src_Dir.Value; 1594 1595 begin 1596 Locate_Directory 1597 (Dir_Id, Data.Display_Directory, 1598 Data.Library_Src_Dir, 1599 Data.Display_Library_Src_Dir); 1600 1601 -- If directory does not exist, report an error 1602 1603 if Data.Library_Src_Dir = No_Name then 1604 1605 -- Get the absolute name of the library directory 1606 -- that does not exist, to report an error. 1607 1608 declare 1609 Dir_Name : constant String := 1610 Get_Name_String (Dir_Id); 1611 1612 begin 1613 if Is_Absolute_Path (Dir_Name) then 1614 Err_Vars.Error_Msg_Name_1 := Dir_Id; 1615 1616 else 1617 Get_Name_String (Data.Directory); 1618 1619 if Name_Buffer (Name_Len) /= 1620 Directory_Separator 1621 then 1622 Name_Len := Name_Len + 1; 1623 Name_Buffer (Name_Len) := 1624 Directory_Separator; 1625 end if; 1626 1627 Name_Buffer 1628 (Name_Len + 1 .. 1629 Name_Len + Dir_Name'Length) := 1630 Dir_Name; 1631 Name_Len := Name_Len + Dir_Name'Length; 1632 Err_Vars.Error_Msg_Name_1 := Name_Find; 1633 end if; 1634 1635 -- Report the error 1636 1637 Error_Msg 1638 (Project, 1639 "Directory { does not exist", 1640 Lib_Src_Dir.Location); 1641 end; 1642 1643 -- Report an error if it is the same as the object 1644 -- directory. 1645 1646 elsif Data.Library_Src_Dir = Data.Object_Directory then 1647 Error_Msg 1648 (Project, 1649 "directory to copy interfaces cannot be " & 1650 "the object directory", 1651 Lib_Src_Dir.Location); 1652 Data.Library_Src_Dir := No_Name; 1653 1654 -- Check if it is the same as one of the source 1655 -- directories. 1656 1657 else 1658 declare 1659 Src_Dirs : String_List_Id := Data.Source_Dirs; 1660 Src_Dir : String_Element; 1661 1662 begin 1663 while Src_Dirs /= Nil_String loop 1664 Src_Dir := String_Elements.Table (Src_Dirs); 1665 Src_Dirs := Src_Dir.Next; 1666 1667 -- Report an error if it is one of the 1668 -- source directories. 1669 1670 if Data.Library_Src_Dir = Src_Dir.Value then 1671 Error_Msg 1672 (Project, 1673 "directory to copy interfaces cannot " & 1674 "be one of the source directories", 1675 Lib_Src_Dir.Location); 1676 Data.Library_Src_Dir := No_Name; 1677 exit; 1678 end if; 1679 end loop; 1680 end; 1681 1682 if Data.Library_Src_Dir /= No_Name 1683 and then Current_Verbosity = High 1684 then 1685 Write_Str ("Directory to copy interfaces ="""); 1686 Write_Str (Get_Name_String (Data.Library_Dir)); 1687 Write_Line (""""); 1688 end if; 1689 end if; 1690 end; 1691 end if; 1692 1693 if not Lib_Symbol_File.Default then 1694 Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value; 1695 1696 Get_Name_String (Lib_Symbol_File.Value); 1697 1698 if Name_Len = 0 then 1699 Error_Msg 1700 (Project, 1701 "symbol file name cannot be an empty string", 1702 Lib_Symbol_File.Location); 1703 1704 else 1705 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); 1706 1707 if OK then 1708 for J in 1 .. Name_Len loop 1709 if Name_Buffer (J) = '/' 1710 or else Name_Buffer (J) = Directory_Separator 1711 then 1712 OK := False; 1713 exit; 1714 end if; 1715 end loop; 1716 end if; 1717 1718 if not OK then 1719 Error_Msg_Name_1 := Lib_Symbol_File.Value; 1720 Error_Msg 1721 (Project, 1722 "symbol file name { is illegal. " & 1723 "Name canot include directory info.", 1724 Lib_Symbol_File.Location); 1725 end if; 1726 end if; 1727 end if; 1728 1729 if not Lib_Symbol_Policy.Default then 1730 declare 1731 Value : constant String := 1732 To_Lower 1733 (Get_Name_String (Lib_Symbol_Policy.Value)); 1734 1735 begin 1736 if Value = "autonomous" or else Value = "default" then 1737 Data.Symbol_Data.Symbol_Policy := Autonomous; 1738 1739 elsif Value = "compliant" then 1740 Data.Symbol_Data.Symbol_Policy := Compliant; 1741 1742 elsif Value = "controlled" then 1743 Data.Symbol_Data.Symbol_Policy := Controlled; 1744 1745 else 1746 Error_Msg 1747 (Project, 1748 "illegal value for Library_Symbol_Policy", 1749 Lib_Symbol_Policy.Location); 1750 end if; 1751 end; 1752 end if; 1753 1754 if Lib_Ref_Symbol_File.Default then 1755 if Data.Symbol_Data.Symbol_Policy /= Autonomous then 1756 Error_Msg 1757 (Project, 1758 "a reference symbol file need to be defined", 1759 Lib_Symbol_Policy.Location); 1760 end if; 1761 1762 else 1763 Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value; 1764 1765 Get_Name_String (Lib_Symbol_File.Value); 1766 1767 if Name_Len = 0 then 1768 Error_Msg 1769 (Project, 1770 "reference symbol file name cannot be an empty string", 1771 Lib_Symbol_File.Location); 1772 1773 else 1774 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); 1775 1776 if OK then 1777 for J in 1 .. Name_Len loop 1778 if Name_Buffer (J) = '/' 1779 or else Name_Buffer (J) = Directory_Separator 1780 then 1781 OK := False; 1782 exit; 1783 end if; 1784 end loop; 1785 end if; 1786 1787 if not OK then 1788 Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; 1789 Error_Msg 1790 (Project, 1791 "reference symbol file { name is illegal. " & 1792 "Name canot include directory info.", 1793 Lib_Ref_Symbol_File.Location); 1794 end if; 1795 1796 if not Is_Regular_File 1797 (Get_Name_String (Data.Object_Directory) & 1798 Directory_Separator & 1799 Get_Name_String (Lib_Ref_Symbol_File.Value)) 1800 then 1801 Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; 1802 Error_Msg 1803 (Project, 1804 "library reference symbol file { does not exist", 1805 Lib_Ref_Symbol_File.Location); 1806 end if; 1807 1808 if Data.Symbol_Data.Symbol_File /= No_Name then 1809 declare 1810 Symbol : String := 1811 Get_Name_String 1812 (Data.Symbol_Data.Symbol_File); 1813 1814 Reference : String := 1815 Get_Name_String 1816 (Data.Symbol_Data.Reference); 1817 1818 begin 1819 Canonical_Case_File_Name (Symbol); 1820 Canonical_Case_File_Name (Reference); 1821 1822 if Symbol = Reference then 1823 Error_Msg 1824 (Project, 1825 "reference symbol file and symbol file " & 1826 "cannot be the same file", 1827 Lib_Ref_Symbol_File.Location); 1828 end if; 1829 end; 1830 end if; 1831 end if; 1832 end if; 1833 end if; 1834 end Standalone_Library; 1835 end if; 1836 1837 -- Put the list of Mains, if any, in the project data 1838 1839 declare 1840 Mains : constant Variable_Value := 1841 Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes); 1842 1843 begin 1844 Data.Mains := Mains.Values; 1845 1846 -- If no Mains were specified, and if we are an extending 1847 -- project, inherit the Mains from the project we are extending. 1848 1849 if Mains.Default then 1850 if Data.Extends /= No_Project then 1851 Data.Mains := Projects.Table (Data.Extends).Mains; 1852 end if; 1853 1854 -- In a library project file, Main cannot be specified 1855 1856 elsif Data.Library then 1857 Error_Msg 1858 (Project, 1859 "a library project file cannot have Main specified", 1860 Mains.Location); 1861 end if; 1862 end; 1863 1864 Projects.Table (Project) := Data; 1865 1866 Free_Naming_Exceptions; 1867 end Ada_Check; 1868 1869 ------------------- 1870 -- ALI_File_Name -- 1871 ------------------- 1872 1873 function ALI_File_Name (Source : String) return String is 1874 begin 1875 -- If the source name has an extension, then replace it with 1876 -- the ALI suffix. 1877 1878 for Index in reverse Source'First + 1 .. Source'Last loop 1879 if Source (Index) = '.' then 1880 return Source (Source'First .. Index - 1) & ALI_Suffix; 1881 end if; 1882 end loop; 1883 1884 -- If there is no dot, or if it is the first character, just add the 1885 -- ALI suffix. 1886 1887 return Source & ALI_Suffix; 1888 end ALI_File_Name; 1889 1890 -------------------- 1891 -- Check_Ada_Name -- 1892 -------------------- 1893 1894 procedure Check_Ada_Name 1895 (Name : String; 1896 Unit : out Name_Id) 1897 is 1898 The_Name : String := Name; 1899 Real_Name : Name_Id; 1900 Need_Letter : Boolean := True; 1901 Last_Underscore : Boolean := False; 1902 OK : Boolean := The_Name'Length > 0; 1903 1904 begin 1905 To_Lower (The_Name); 1906 1907 Name_Len := The_Name'Length; 1908 Name_Buffer (1 .. Name_Len) := The_Name; 1909 Real_Name := Name_Find; 1910 1911 -- Check first that the given name is not an Ada reserved word 1912 1913 if Get_Name_Table_Byte (Real_Name) /= 0 1914 and then Real_Name /= Name_Project 1915 and then Real_Name /= Name_Extends 1916 and then Real_Name /= Name_External 1917 then 1918 Unit := No_Name; 1919 1920 if Current_Verbosity = High then 1921 Write_Str (The_Name); 1922 Write_Line (" is an Ada reserved word."); 1923 end if; 1924 1925 return; 1926 end if; 1927 1928 for Index in The_Name'Range loop 1929 if Need_Letter then 1930 1931 -- We need a letter (at the beginning, and following a dot), 1932 -- but we don't have one. 1933 1934 if Is_Letter (The_Name (Index)) then 1935 Need_Letter := False; 1936 1937 else 1938 OK := False; 1939 1940 if Current_Verbosity = High then 1941 Write_Int (Types.Int (Index)); 1942 Write_Str (": '"); 1943 Write_Char (The_Name (Index)); 1944 Write_Line ("' is not a letter."); 1945 end if; 1946 1947 exit; 1948 end if; 1949 1950 elsif Last_Underscore 1951 and then (The_Name (Index) = '_' or else The_Name (Index) = '.') 1952 then 1953 -- Two underscores are illegal, and a dot cannot follow 1954 -- an underscore. 1955 1956 OK := False; 1957 1958 if Current_Verbosity = High then 1959 Write_Int (Types.Int (Index)); 1960 Write_Str (": '"); 1961 Write_Char (The_Name (Index)); 1962 Write_Line ("' is illegal here."); 1963 end if; 1964 1965 exit; 1966 1967 elsif The_Name (Index) = '.' then 1968 1969 -- We need a letter after a dot 1970 1971 Need_Letter := True; 1972 1973 elsif The_Name (Index) = '_' then 1974 Last_Underscore := True; 1975 1976 else 1977 -- We need an letter or a digit 1978 1979 Last_Underscore := False; 1980 1981 if not Is_Alphanumeric (The_Name (Index)) then 1982 OK := False; 1983 1984 if Current_Verbosity = High then 1985 Write_Int (Types.Int (Index)); 1986 Write_Str (": '"); 1987 Write_Char (The_Name (Index)); 1988 Write_Line ("' is not alphanumeric."); 1989 end if; 1990 1991 exit; 1992 end if; 1993 end if; 1994 end loop; 1995 1996 -- Cannot end with an underscore or a dot 1997 1998 OK := OK and then not Need_Letter and then not Last_Underscore; 1999 2000 if OK then 2001 Unit := Real_Name; 2002 2003 else 2004 -- Signal a problem with No_Name 2005 2006 Unit := No_Name; 2007 end if; 2008 end Check_Ada_Name; 2009 2010 ----------------------------- 2011 -- Check_Ada_Naming_Scheme -- 2012 ----------------------------- 2013 2014 procedure Check_Ada_Naming_Scheme 2015 (Project : Project_Id; 2016 Naming : Naming_Data) 2017 is 2018 begin 2019 -- Only check if we are not using the standard naming scheme 2020 2021 if Naming /= Standard_Naming_Data then 2022 declare 2023 Dot_Replacement : constant String := 2024 Get_Name_String 2025 (Naming.Dot_Replacement); 2026 2027 Spec_Suffix : constant String := 2028 Get_Name_String 2029 (Naming.Current_Spec_Suffix); 2030 2031 Body_Suffix : constant String := 2032 Get_Name_String 2033 (Naming.Current_Body_Suffix); 2034 2035 Separate_Suffix : constant String := 2036 Get_Name_String 2037 (Naming.Separate_Suffix); 2038 2039 begin 2040 -- Dot_Replacement cannot 2041 -- - be empty 2042 -- - start or end with an alphanumeric 2043 -- - be a single '_' 2044 -- - start with an '_' followed by an alphanumeric 2045 -- - contain a '.' except if it is "." 2046 2047 if Dot_Replacement'Length = 0 2048 or else Is_Alphanumeric 2049 (Dot_Replacement (Dot_Replacement'First)) 2050 or else Is_Alphanumeric 2051 (Dot_Replacement (Dot_Replacement'Last)) 2052 or else (Dot_Replacement (Dot_Replacement'First) = '_' 2053 and then 2054 (Dot_Replacement'Length = 1 2055 or else 2056 Is_Alphanumeric 2057 (Dot_Replacement (Dot_Replacement'First + 1)))) 2058 or else (Dot_Replacement'Length > 1 2059 and then 2060 Index (Source => Dot_Replacement, 2061 Pattern => ".") /= 0) 2062 then 2063 Error_Msg 2064 (Project, 2065 '"' & Dot_Replacement & 2066 """ is illegal for Dot_Replacement.", 2067 Naming.Dot_Repl_Loc); 2068 end if; 2069 2070 -- Suffixes cannot 2071 -- - be empty 2072 2073 if Is_Illegal_Suffix 2074 (Spec_Suffix, Dot_Replacement = ".") 2075 then 2076 Err_Vars.Error_Msg_Name_1 := Naming.Current_Spec_Suffix; 2077 Error_Msg 2078 (Project, 2079 "{ is illegal for Spec_Suffix", 2080 Naming.Spec_Suffix_Loc); 2081 end if; 2082 2083 if Is_Illegal_Suffix 2084 (Body_Suffix, Dot_Replacement = ".") 2085 then 2086 Err_Vars.Error_Msg_Name_1 := Naming.Current_Body_Suffix; 2087 Error_Msg 2088 (Project, 2089 "{ is illegal for Body_Suffix", 2090 Naming.Body_Suffix_Loc); 2091 end if; 2092 2093 if Body_Suffix /= Separate_Suffix then 2094 if Is_Illegal_Suffix 2095 (Separate_Suffix, Dot_Replacement = ".") 2096 then 2097 Err_Vars.Error_Msg_Name_1 := Naming.Separate_Suffix; 2098 Error_Msg 2099 (Project, 2100 "{ is illegal for Separate_Suffix", 2101 Naming.Sep_Suffix_Loc); 2102 end if; 2103 end if; 2104 2105 -- Spec_Suffix cannot have the same termination as 2106 -- Body_Suffix or Separate_Suffix 2107 2108 if Spec_Suffix'Length <= Body_Suffix'Length 2109 and then 2110 Body_Suffix (Body_Suffix'Last - 2111 Spec_Suffix'Length + 1 .. 2112 Body_Suffix'Last) = Spec_Suffix 2113 then 2114 Error_Msg 2115 (Project, 2116 "Body_Suffix (""" & 2117 Body_Suffix & 2118 """) cannot end with" & 2119 " Spec_Suffix (""" & 2120 Spec_Suffix & """).", 2121 Naming.Body_Suffix_Loc); 2122 end if; 2123 2124 if Body_Suffix /= Separate_Suffix 2125 and then Spec_Suffix'Length <= Separate_Suffix'Length 2126 and then 2127 Separate_Suffix 2128 (Separate_Suffix'Last - Spec_Suffix'Length + 1 2129 .. 2130 Separate_Suffix'Last) = Spec_Suffix 2131 then 2132 Error_Msg 2133 (Project, 2134 "Separate_Suffix (""" & 2135 Separate_Suffix & 2136 """) cannot end with" & 2137 " Spec_Suffix (""" & 2138 Spec_Suffix & """).", 2139 Naming.Sep_Suffix_Loc); 2140 end if; 2141 end; 2142 end if; 2143 end Check_Ada_Naming_Scheme; 2144 2145 --------------- 2146 -- Error_Msg -- 2147 --------------- 2148 2149 procedure Error_Msg 2150 (Project : Project_Id; 2151 Msg : String; 2152 Flag_Location : Source_Ptr) 2153 is 2154 Error_Buffer : String (1 .. 5_000); 2155 Error_Last : Natural := 0; 2156 Msg_Name : Natural := 0; 2157 First : Positive := Msg'First; 2158 2159 procedure Add (C : Character); 2160 -- Add a character to the buffer 2161 2162 procedure Add (S : String); 2163 -- Add a string to the buffer 2164 2165 procedure Add (Id : Name_Id); 2166 -- Add a name to the buffer 2167 2168 --------- 2169 -- Add -- 2170 --------- 2171 2172 procedure Add (C : Character) is 2173 begin 2174 Error_Last := Error_Last + 1; 2175 Error_Buffer (Error_Last) := C; 2176 end Add; 2177 2178 procedure Add (S : String) is 2179 begin 2180 Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S; 2181 Error_Last := Error_Last + S'Length; 2182 end Add; 2183 2184 procedure Add (Id : Name_Id) is 2185 begin 2186 Get_Name_String (Id); 2187 Add (Name_Buffer (1 .. Name_Len)); 2188 end Add; 2189 2190 -- Start of processing for Error_Msg 2191 2192 begin 2193 if Error_Report = null then 2194 Prj.Err.Error_Msg (Msg, Flag_Location); 2195 return; 2196 end if; 2197 2198 if Msg (First) = '\' then 2199 2200 -- Continuation character, ignore. 2201 2202 First := First + 1; 2203 2204 elsif Msg (First) = '?' then 2205 2206 -- Warning character. It is always the first one in this package 2207 2208 First := First + 1; 2209 Add ("Warning: "); 2210 end if; 2211 2212 for Index in First .. Msg'Last loop 2213 if Msg (Index) = '{' or else Msg (Index) = '%' then 2214 2215 -- Include a name between double quotes. 2216 2217 Msg_Name := Msg_Name + 1; 2218 Add ('"'); 2219 2220 case Msg_Name is 2221 when 1 => Add (Err_Vars.Error_Msg_Name_1); 2222 when 2 => Add (Err_Vars.Error_Msg_Name_2); 2223 when 3 => Add (Err_Vars.Error_Msg_Name_3); 2224 2225 when others => null; 2226 end case; 2227 2228 Add ('"'); 2229 2230 else 2231 Add (Msg (Index)); 2232 end if; 2233 2234 end loop; 2235 2236 Error_Report (Error_Buffer (1 .. Error_Last), Project); 2237 end Error_Msg; 2238 2239 -------------- 2240 -- Get_Unit -- 2241 -------------- 2242 2243 procedure Get_Unit 2244 (Canonical_File_Name : Name_Id; 2245 Naming : Naming_Data; 2246 Unit_Name : out Name_Id; 2247 Unit_Kind : out Spec_Or_Body; 2248 Needs_Pragma : out Boolean) 2249 is 2250 function Check_Exception (Canonical : Name_Id) return Boolean; 2251 pragma Inline (Check_Exception); 2252 -- Check if Canonical is one of the exceptions in List. 2253 -- Returns True if Get_Unit should exit 2254 2255 --------------------- 2256 -- Check_Exception -- 2257 --------------------- 2258 2259 function Check_Exception (Canonical : Name_Id) return Boolean is 2260 Info : Unit_Info := Naming_Exceptions.Get (Canonical); 2261 VMS_Name : Name_Id; 2262 2263 begin 2264 if Info = No_Unit then 2265 if Hostparm.OpenVMS then 2266 VMS_Name := Canonical; 2267 Get_Name_String (VMS_Name); 2268 2269 if Name_Buffer (Name_Len) = '.' then 2270 Name_Len := Name_Len - 1; 2271 VMS_Name := Name_Find; 2272 end if; 2273 2274 Info := Naming_Exceptions.Get (VMS_Name); 2275 end if; 2276 2277 if Info = No_Unit then 2278 return False; 2279 end if; 2280 end if; 2281 2282 Unit_Kind := Info.Kind; 2283 Unit_Name := Info.Unit; 2284 Needs_Pragma := True; 2285 return True; 2286 end Check_Exception; 2287 2288 -- Start of processing for Get_Unit 2289 2290 begin 2291 Needs_Pragma := False; 2292 2293 if Check_Exception (Canonical_File_Name) then 2294 return; 2295 end if; 2296 2297 Get_Name_String (Canonical_File_Name); 2298 2299 declare 2300 File : String := Name_Buffer (1 .. Name_Len); 2301 First : constant Positive := File'First; 2302 Last : Natural := File'Last; 2303 Standard_GNAT : Boolean; 2304 2305 begin 2306 Standard_GNAT := 2307 Naming.Current_Spec_Suffix = Default_Ada_Spec_Suffix 2308 and then Naming.Current_Body_Suffix = Default_Ada_Body_Suffix; 2309 2310 -- Check if the end of the file name is Specification_Append 2311 2312 Get_Name_String (Naming.Current_Spec_Suffix); 2313 2314 if File'Length > Name_Len 2315 and then File (Last - Name_Len + 1 .. Last) = 2316 Name_Buffer (1 .. Name_Len) 2317 then 2318 -- We have a spec 2319 2320 Unit_Kind := Specification; 2321 Last := Last - Name_Len; 2322 2323 if Current_Verbosity = High then 2324 Write_Str (" Specification: "); 2325 Write_Line (File (First .. Last)); 2326 end if; 2327 2328 else 2329 Get_Name_String (Naming.Current_Body_Suffix); 2330 2331 -- Check if the end of the file name is Body_Append 2332 2333 if File'Length > Name_Len 2334 and then File (Last - Name_Len + 1 .. Last) = 2335 Name_Buffer (1 .. Name_Len) 2336 then 2337 -- We have a body 2338 2339 Unit_Kind := Body_Part; 2340 Last := Last - Name_Len; 2341 2342 if Current_Verbosity = High then 2343 Write_Str (" Body: "); 2344 Write_Line (File (First .. Last)); 2345 end if; 2346 2347 elsif Naming.Separate_Suffix /= Naming.Current_Spec_Suffix then 2348 Get_Name_String (Naming.Separate_Suffix); 2349 2350 -- Check if the end of the file name is Separate_Append 2351 2352 if File'Length > Name_Len 2353 and then File (Last - Name_Len + 1 .. Last) = 2354 Name_Buffer (1 .. Name_Len) 2355 then 2356 -- We have a separate (a body) 2357 2358 Unit_Kind := Body_Part; 2359 Last := Last - Name_Len; 2360 2361 if Current_Verbosity = High then 2362 Write_Str (" Separate: "); 2363 Write_Line (File (First .. Last)); 2364 end if; 2365 2366 else 2367 Last := 0; 2368 end if; 2369 2370 else 2371 Last := 0; 2372 end if; 2373 end if; 2374 2375 if Last = 0 then 2376 2377 -- This is not a source file 2378 2379 Unit_Name := No_Name; 2380 Unit_Kind := Specification; 2381 2382 if Current_Verbosity = High then 2383 Write_Line (" Not a valid file name."); 2384 end if; 2385 2386 return; 2387 end if; 2388 2389 Get_Name_String (Naming.Dot_Replacement); 2390 Standard_GNAT := 2391 Standard_GNAT and then Name_Buffer (1 .. Name_Len) = "-"; 2392 2393 if Name_Buffer (1 .. Name_Len) /= "." then 2394 2395 -- If Dot_Replacement is not a single dot, 2396 -- then there should not be any dot in the name. 2397 2398 for Index in First .. Last loop 2399 if File (Index) = '.' then 2400 if Current_Verbosity = High then 2401 Write_Line 2402 (" Not a valid file name (some dot not replaced)."); 2403 end if; 2404 2405 Unit_Name := No_Name; 2406 return; 2407 2408 end if; 2409 end loop; 2410 2411 -- Replace the substring Dot_Replacement with dots 2412 2413 declare 2414 Index : Positive := First; 2415 2416 begin 2417 while Index <= Last - Name_Len + 1 loop 2418 2419 if File (Index .. Index + Name_Len - 1) = 2420 Name_Buffer (1 .. Name_Len) 2421 then 2422 File (Index) := '.'; 2423 2424 if Name_Len > 1 and then Index < Last then 2425 File (Index + 1 .. Last - Name_Len + 1) := 2426 File (Index + Name_Len .. Last); 2427 end if; 2428 2429 Last := Last - Name_Len + 1; 2430 end if; 2431 2432 Index := Index + 1; 2433 end loop; 2434 end; 2435 end if; 2436 2437 -- Check if the casing is right 2438 2439 declare 2440 Src : String := File (First .. Last); 2441 2442 begin 2443 case Naming.Casing is 2444 when All_Lower_Case => 2445 Fixed.Translate 2446 (Source => Src, 2447 Mapping => Lower_Case_Map); 2448 2449 when All_Upper_Case => 2450 Fixed.Translate 2451 (Source => Src, 2452 Mapping => Upper_Case_Map); 2453 2454 when Mixed_Case | Unknown => 2455 null; 2456 end case; 2457 2458 if Src /= File (First .. Last) then 2459 if Current_Verbosity = High then 2460 Write_Line (" Not a valid file name (casing)."); 2461 end if; 2462 2463 Unit_Name := No_Name; 2464 return; 2465 end if; 2466 2467 -- We put the name in lower case 2468 2469 Fixed.Translate 2470 (Source => Src, 2471 Mapping => Lower_Case_Map); 2472 2473 -- In the standard GNAT naming scheme, check for special cases: 2474 -- children or separates of A, G, I or S, and run time sources. 2475 2476 if Standard_GNAT and then Src'Length >= 3 then 2477 declare 2478 S1 : constant Character := Src (Src'First); 2479 S2 : constant Character := Src (Src'First + 1); 2480 2481 begin 2482 if S1 = 'a' or else S1 = 'g' 2483 or else S1 = 'i' or else S1 = 's' 2484 then 2485 -- Children or separates of packages A, G, I or S 2486 2487 if (Hostparm.OpenVMS and then S2 = '$') 2488 or else (not Hostparm.OpenVMS and then S2 = '~') 2489 then 2490 Src (Src'First + 1) := '.'; 2491 2492 -- If it is potentially a run time source, disable 2493 -- filling of the mapping file to avoid warnings. 2494 2495 elsif S2 = '.' then 2496 Set_Mapping_File_Initial_State_To_Empty; 2497 end if; 2498 2499 end if; 2500 end; 2501 end if; 2502 2503 if Current_Verbosity = High then 2504 Write_Str (" "); 2505 Write_Line (Src); 2506 end if; 2507 2508 -- Now, we check if this name is a valid unit name 2509 2510 Check_Ada_Name (Name => Src, Unit => Unit_Name); 2511 end; 2512 2513 end; 2514 end Get_Unit; 2515 2516 ----------------------- 2517 -- Is_Illegal_Suffix -- 2518 ----------------------- 2519 2520 function Is_Illegal_Suffix 2521 (Suffix : String; 2522 Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean 2523 is 2524 begin 2525 if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then 2526 return True; 2527 end if; 2528 2529 -- If dot replacement is a single dot, and first character of 2530 -- suffix is also a dot 2531 2532 if Dot_Replacement_Is_A_Single_Dot 2533 and then Suffix (Suffix'First) = '.' 2534 then 2535 for Index in Suffix'First + 1 .. Suffix'Last loop 2536 2537 -- If there is another dot 2538 2539 if Suffix (Index) = '.' then 2540 2541 -- It is illegal to have a letter following the initial dot 2542 2543 return Is_Letter (Suffix (Suffix'First + 1)); 2544 end if; 2545 end loop; 2546 end if; 2547 2548 -- Everything is OK 2549 2550 return False; 2551 end Is_Illegal_Suffix; 2552 2553 -------------------------------- 2554 -- Language_Independent_Check -- 2555 -------------------------------- 2556 2557 procedure Language_Independent_Check 2558 (Project : Project_Id; 2559 Report_Error : Put_Line_Access) 2560 is 2561 Last_Source_Dir : String_List_Id := Nil_String; 2562 Data : Project_Data := Projects.Table (Project); 2563 2564 procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr); 2565 -- Find one or several source directories, and add them 2566 -- to the list of source directories of the project. 2567 2568 ---------------------- 2569 -- Find_Source_Dirs -- 2570 ---------------------- 2571 2572 procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is 2573 Directory : constant String := Get_Name_String (From); 2574 Element : String_Element; 2575 2576 Canonical_Directory_Id : Name_Id; 2577 pragma Unreferenced (Canonical_Directory_Id); 2578 -- Is this in fact being used for anything useful ??? 2579 2580 procedure Recursive_Find_Dirs (Path : Name_Id); 2581 -- Find all the subdirectories (recursively) of Path and add them 2582 -- to the list of source directories of the project. 2583 2584 ------------------------- 2585 -- Recursive_Find_Dirs -- 2586 ------------------------- 2587 2588 procedure Recursive_Find_Dirs (Path : Name_Id) is 2589 Dir : Dir_Type; 2590 Name : String (1 .. 250); 2591 Last : Natural; 2592 List : String_List_Id := Data.Source_Dirs; 2593 Element : String_Element; 2594 Found : Boolean := False; 2595 2596 Canonical_Path : Name_Id := No_Name; 2597 2598 begin 2599 Get_Name_String (Path); 2600 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2601 2602 declare 2603 The_Path : constant String := 2604 Normalize_Pathname 2605 (Name => Name_Buffer (1 .. Name_Len)) & 2606 Directory_Separator; 2607 2608 The_Path_Last : constant Natural := 2609 Compute_Directory_Last (The_Path); 2610 2611 begin 2612 Name_Len := The_Path_Last - The_Path'First + 1; 2613 Name_Buffer (1 .. Name_Len) := 2614 The_Path (The_Path'First .. The_Path_Last); 2615 Canonical_Path := Name_Find; 2616 2617 -- To avoid processing the same directory several times, check 2618 -- if the directory is already in Recursive_Dirs. If it is, 2619 -- then there is nothing to do, just return. If it is not, put 2620 -- it there and continue recursive processing. 2621 2622 if Recursive_Dirs.Get (Canonical_Path) then 2623 return; 2624 2625 else 2626 Recursive_Dirs.Set (Canonical_Path, True); 2627 end if; 2628 2629 -- Check if directory is already in list 2630 2631 while List /= Nil_String loop 2632 Element := String_Elements.Table (List); 2633 2634 if Element.Value /= No_Name then 2635 Get_Name_String (Element.Value); 2636 Found := 2637 The_Path (The_Path'First .. The_Path_Last) = 2638 Name_Buffer (1 .. Name_Len); 2639 exit when Found; 2640 end if; 2641 2642 List := Element.Next; 2643 end loop; 2644 2645 -- If directory is not already in list, put it there 2646 2647 if not Found then 2648 if Current_Verbosity = High then 2649 Write_Str (" "); 2650 Write_Line (The_Path (The_Path'First .. The_Path_Last)); 2651 end if; 2652 2653 String_Elements.Increment_Last; 2654 Element := 2655 (Value => Canonical_Path, 2656 Display_Value => No_Name, 2657 Location => No_Location, 2658 Flag => False, 2659 Next => Nil_String); 2660 2661 -- Case of first source directory 2662 2663 if Last_Source_Dir = Nil_String then 2664 Data.Source_Dirs := String_Elements.Last; 2665 2666 -- Here we already have source directories. 2667 2668 else 2669 -- Link the previous last to the new one 2670 2671 String_Elements.Table (Last_Source_Dir).Next := 2672 String_Elements.Last; 2673 end if; 2674 2675 -- And register this source directory as the new last 2676 2677 Last_Source_Dir := String_Elements.Last; 2678 String_Elements.Table (Last_Source_Dir) := Element; 2679 end if; 2680 2681 -- Now look for subdirectories. We do that even when this 2682 -- directory is already in the list, because some of its 2683 -- subdirectories may not be in the list yet. 2684 2685 Open (Dir, The_Path (The_Path'First .. The_Path_Last)); 2686 2687 loop 2688 Read (Dir, Name, Last); 2689 exit when Last = 0; 2690 2691 if Name (1 .. Last) /= "." 2692 and then Name (1 .. Last) /= ".." 2693 then 2694 -- Avoid . and .. 2695 2696 if Current_Verbosity = High then 2697 Write_Str (" Checking "); 2698 Write_Line (Name (1 .. Last)); 2699 end if; 2700 2701 declare 2702 Path_Name : String := 2703 Normalize_Pathname 2704 (Name => Name (1 .. Last), 2705 Directory => 2706 The_Path 2707 (The_Path'First .. The_Path_Last)); 2708 2709 begin 2710 Canonical_Case_File_Name (Path_Name); 2711 2712 if Is_Directory (Path_Name) then 2713 2714 -- We have found a new subdirectory, call self 2715 2716 Name_Len := Path_Name'Length; 2717 Name_Buffer (1 .. Name_Len) := Path_Name; 2718 Recursive_Find_Dirs (Name_Find); 2719 end if; 2720 end; 2721 end if; 2722 end loop; 2723 2724 Close (Dir); 2725 end; 2726 2727 exception 2728 when Directory_Error => 2729 null; 2730 end Recursive_Find_Dirs; 2731 2732 -- Start of processing for Find_Source_Dirs 2733 2734 begin 2735 if Current_Verbosity = High then 2736 Write_Str ("Find_Source_Dirs ("""); 2737 end if; 2738 2739 Get_Name_String (From); 2740 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2741 2742 -- Directory := Name_Buffer (1 .. Name_Len); 2743 -- Why is above line commented out ??? 2744 2745 Canonical_Directory_Id := Name_Find; 2746 -- What is purpose of above assignment ??? 2747 -- Are we sure it is being used ??? 2748 2749 if Current_Verbosity = High then 2750 Write_Str (Directory); 2751 Write_Line (""")"); 2752 end if; 2753 2754 -- First, check if we are looking for a directory tree, 2755 -- indicated by "/**" at the end. 2756 2757 if Directory'Length >= 3 2758 and then Directory (Directory'Last - 1 .. Directory'Last) = "**" 2759 and then (Directory (Directory'Last - 2) = '/' 2760 or else 2761 Directory (Directory'Last - 2) = Directory_Separator) 2762 then 2763 Data.Known_Order_Of_Source_Dirs := False; 2764 2765 Name_Len := Directory'Length - 3; 2766 2767 if Name_Len = 0 then 2768 2769 -- This is the case of "/**": all directories 2770 -- in the file system. 2771 2772 Name_Len := 1; 2773 Name_Buffer (1) := Directory (Directory'First); 2774 2775 else 2776 Name_Buffer (1 .. Name_Len) := 2777 Directory (Directory'First .. Directory'Last - 3); 2778 end if; 2779 2780 if Current_Verbosity = High then 2781 Write_Str ("Looking for all subdirectories of """); 2782 Write_Str (Name_Buffer (1 .. Name_Len)); 2783 Write_Line (""""); 2784 end if; 2785 2786 declare 2787 Base_Dir : constant Name_Id := Name_Find; 2788 Root_Dir : constant String := 2789 Normalize_Pathname 2790 (Name => Get_Name_String (Base_Dir), 2791 Directory => 2792 Get_Name_String (Data.Display_Directory)); 2793 2794 begin 2795 if Root_Dir'Length = 0 then 2796 Err_Vars.Error_Msg_Name_1 := Base_Dir; 2797 2798 if Location = No_Location then 2799 Error_Msg 2800 (Project, 2801 "{ is not a valid directory.", 2802 Data.Location); 2803 else 2804 Error_Msg 2805 (Project, 2806 "{ is not a valid directory.", 2807 Location); 2808 end if; 2809 2810 else 2811 -- We have an existing directory, 2812 -- we register it and all of its subdirectories. 2813 2814 if Current_Verbosity = High then 2815 Write_Line ("Looking for source directories:"); 2816 end if; 2817 2818 Name_Len := Root_Dir'Length; 2819 Name_Buffer (1 .. Name_Len) := Root_Dir; 2820 Recursive_Find_Dirs (Name_Find); 2821 2822 if Current_Verbosity = High then 2823 Write_Line ("End of looking for source directories."); 2824 end if; 2825 end if; 2826 end; 2827 2828 -- We have a single directory 2829 2830 else 2831 declare 2832 Path_Name : Name_Id; 2833 Display_Path_Name : Name_Id; 2834 begin 2835 Locate_Directory 2836 (From, Data.Display_Directory, Path_Name, Display_Path_Name); 2837 if Path_Name = No_Name then 2838 Err_Vars.Error_Msg_Name_1 := From; 2839 2840 if Location = No_Location then 2841 Error_Msg 2842 (Project, 2843 "{ is not a valid directory", 2844 Data.Location); 2845 else 2846 Error_Msg 2847 (Project, 2848 "{ is not a valid directory", 2849 Location); 2850 end if; 2851 else 2852 2853 -- As it is an existing directory, we add it to 2854 -- the list of directories. 2855 2856 String_Elements.Increment_Last; 2857 Element.Value := Path_Name; 2858 Element.Display_Value := Display_Path_Name; 2859 2860 if Last_Source_Dir = Nil_String then 2861 2862 -- This is the first source directory 2863 2864 Data.Source_Dirs := String_Elements.Last; 2865 2866 else 2867 -- We already have source directories, 2868 -- link the previous last to the new one. 2869 2870 String_Elements.Table (Last_Source_Dir).Next := 2871 String_Elements.Last; 2872 end if; 2873 2874 -- And register this source directory as the new last 2875 2876 Last_Source_Dir := String_Elements.Last; 2877 String_Elements.Table (Last_Source_Dir) := Element; 2878 end if; 2879 end; 2880 end if; 2881 end Find_Source_Dirs; 2882 2883 -- Start of processing for Language_Independent_Check 2884 2885 begin 2886 if Data.Language_Independent_Checked then 2887 return; 2888 end if; 2889 2890 Data.Language_Independent_Checked := True; 2891 2892 Error_Report := Report_Error; 2893 2894 Recursive_Dirs.Reset; 2895 2896 if Current_Verbosity = High then 2897 Write_Line ("Starting to look for directories"); 2898 end if; 2899 2900 -- Check the object directory 2901 2902 declare 2903 Object_Dir : constant Variable_Value := 2904 Util.Value_Of (Name_Object_Dir, Data.Decl.Attributes); 2905 2906 begin 2907 pragma Assert (Object_Dir.Kind = Single, 2908 "Object_Dir is not a single string"); 2909 2910 -- We set the object directory to its default 2911 2912 Data.Object_Directory := Data.Directory; 2913 Data.Display_Object_Dir := Data.Display_Directory; 2914 2915 if Object_Dir.Value /= Empty_String then 2916 2917 Get_Name_String (Object_Dir.Value); 2918 2919 if Name_Len = 0 then 2920 Error_Msg 2921 (Project, 2922 "Object_Dir cannot be empty", 2923 Object_Dir.Location); 2924 2925 else 2926 -- We check that the specified object directory 2927 -- does exist. 2928 2929 Locate_Directory 2930 (Object_Dir.Value, Data.Display_Directory, 2931 Data.Object_Directory, Data.Display_Object_Dir); 2932 2933 if Data.Object_Directory = No_Name then 2934 -- The object directory does not exist, report an error 2935 Err_Vars.Error_Msg_Name_1 := Object_Dir.Value; 2936 Error_Msg 2937 (Project, 2938 "the object directory { cannot be found", 2939 Data.Location); 2940 2941 -- Do not keep a nil Object_Directory. Set it to the 2942 -- specified (relative or absolute) path. 2943 -- This is for the benefit of tools that recover from 2944 -- errors; for example, these tools could create the 2945 -- non existent directory. 2946 2947 Data.Display_Object_Dir := Object_Dir.Value; 2948 Get_Name_String (Object_Dir.Value); 2949 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2950 Data.Object_Directory := Name_Find; 2951 end if; 2952 end if; 2953 end if; 2954 end; 2955 2956 if Current_Verbosity = High then 2957 if Data.Object_Directory = No_Name then 2958 Write_Line ("No object directory"); 2959 else 2960 Write_Str ("Object directory: """); 2961 Write_Str (Get_Name_String (Data.Display_Object_Dir)); 2962 Write_Line (""""); 2963 end if; 2964 end if; 2965 2966 -- Check the exec directory 2967 2968 declare 2969 Exec_Dir : constant Variable_Value := 2970 Util.Value_Of (Name_Exec_Dir, Data.Decl.Attributes); 2971 2972 begin 2973 pragma Assert (Exec_Dir.Kind = Single, 2974 "Exec_Dir is not a single string"); 2975 2976 -- We set the object directory to its default 2977 2978 Data.Exec_Directory := Data.Object_Directory; 2979 Data.Display_Exec_Dir := Data.Display_Object_Dir; 2980 2981 if Exec_Dir.Value /= Empty_String then 2982 2983 Get_Name_String (Exec_Dir.Value); 2984 2985 if Name_Len = 0 then 2986 Error_Msg 2987 (Project, 2988 "Exec_Dir cannot be empty", 2989 Exec_Dir.Location); 2990 2991 else 2992 -- We check that the specified object directory 2993 -- does exist. 2994 2995 Locate_Directory 2996 (Exec_Dir.Value, Data.Directory, 2997 Data.Exec_Directory, Data.Display_Exec_Dir); 2998 2999 if Data.Exec_Directory = No_Name then 3000 Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value; 3001 Error_Msg 3002 (Project, 3003 "the exec directory { cannot be found", 3004 Data.Location); 3005 end if; 3006 end if; 3007 end if; 3008 end; 3009 3010 if Current_Verbosity = High then 3011 if Data.Exec_Directory = No_Name then 3012 Write_Line ("No exec directory"); 3013 else 3014 Write_Str ("Exec directory: """); 3015 Write_Str (Get_Name_String (Data.Display_Exec_Dir)); 3016 Write_Line (""""); 3017 end if; 3018 end if; 3019 3020 -- Look for the source directories 3021 3022 declare 3023 Source_Dirs : constant Variable_Value := 3024 Util.Value_Of 3025 (Name_Source_Dirs, Data.Decl.Attributes); 3026 3027 begin 3028 if Current_Verbosity = High then 3029 Write_Line ("Starting to look for source directories"); 3030 end if; 3031 3032 pragma Assert (Source_Dirs.Kind = List, 3033 "Source_Dirs is not a list"); 3034 3035 if Source_Dirs.Default then 3036 3037 -- No Source_Dirs specified: the single source directory 3038 -- is the one containing the project file 3039 3040 String_Elements.Increment_Last; 3041 Data.Source_Dirs := String_Elements.Last; 3042 String_Elements.Table (Data.Source_Dirs) := 3043 (Value => Data.Directory, 3044 Display_Value => Data.Display_Directory, 3045 Location => No_Location, 3046 Flag => False, 3047 Next => Nil_String); 3048 3049 if Current_Verbosity = High then 3050 Write_Line ("Single source directory:"); 3051 Write_Str (" """); 3052 Write_Str (Get_Name_String (Data.Display_Directory)); 3053 Write_Line (""""); 3054 end if; 3055 3056 elsif Source_Dirs.Values = Nil_String then 3057 3058 -- If Source_Dirs is an empty string list, this means 3059 -- that this project contains no source. For projects that 3060 -- don't extend other projects, this also means that there is no 3061 -- need for an object directory, if not specified. 3062 3063 if Data.Extends = No_Project 3064 and then Data.Object_Directory = Data.Directory 3065 then 3066 Data.Object_Directory := No_Name; 3067 end if; 3068 3069 Data.Source_Dirs := Nil_String; 3070 Data.Sources_Present := False; 3071 3072 else 3073 declare 3074 Source_Dir : String_List_Id := Source_Dirs.Values; 3075 Element : String_Element; 3076 3077 begin 3078 -- We will find the source directories for each 3079 -- element of the list 3080 3081 while Source_Dir /= Nil_String loop 3082 Element := String_Elements.Table (Source_Dir); 3083 Find_Source_Dirs (Element.Value, Element.Location); 3084 Source_Dir := Element.Next; 3085 end loop; 3086 end; 3087 end if; 3088 3089 if Current_Verbosity = High then 3090 Write_Line ("Putting source directories in canonical cases"); 3091 end if; 3092 3093 declare 3094 Current : String_List_Id := Data.Source_Dirs; 3095 Element : String_Element; 3096 3097 begin 3098 while Current /= Nil_String loop 3099 Element := String_Elements.Table (Current); 3100 if Element.Value /= No_Name then 3101 Element.Display_Value := Element.Value; 3102 Get_Name_String (Element.Value); 3103 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 3104 Element.Value := Name_Find; 3105 String_Elements.Table (Current) := Element; 3106 end if; 3107 3108 Current := Element.Next; 3109 end loop; 3110 end; 3111 end; 3112 3113 -- Library attributes 3114 3115 declare 3116 Attributes : constant Prj.Variable_Id := Data.Decl.Attributes; 3117 3118 Lib_Dir : constant Prj.Variable_Value := 3119 Prj.Util.Value_Of (Snames.Name_Library_Dir, Attributes); 3120 3121 Lib_Name : constant Prj.Variable_Value := 3122 Prj.Util.Value_Of (Snames.Name_Library_Name, Attributes); 3123 3124 Lib_Version : constant Prj.Variable_Value := 3125 Prj.Util.Value_Of 3126 (Snames.Name_Library_Version, Attributes); 3127 3128 The_Lib_Kind : constant Prj.Variable_Value := 3129 Prj.Util.Value_Of 3130 (Snames.Name_Library_Kind, Attributes); 3131 3132 begin 3133 -- Special case of extending project 3134 3135 if Data.Extends /= No_Project then 3136 declare 3137 Extended_Data : constant Project_Data := 3138 Projects.Table (Data.Extends); 3139 3140 begin 3141 -- If the project extended is a library project, we inherit 3142 -- the library name, if it is not redefined; we check that 3143 -- the library directory is specified; and we reset the 3144 -- library flag for the extended project. 3145 3146 if Extended_Data.Library then 3147 if Lib_Name.Default then 3148 Data.Library_Name := Extended_Data.Library_Name; 3149 end if; 3150 3151 if Lib_Dir.Default then 3152 3153 -- If the extending project is a virtual project, we 3154 -- put the error message in the library project that 3155 -- is extended, rather than in the extending all project. 3156 -- Of course, we cannot put it in the virtual extending 3157 -- project, because it has no source. 3158 3159 if Data.Virtual then 3160 Error_Msg_Name_1 := Extended_Data.Name; 3161 3162 Error_Msg 3163 (Project, 3164 "library project % cannot be virtually extended", 3165 Extended_Data.Location); 3166 3167 else 3168 Error_Msg 3169 (Project, 3170 "a project extending a library project must " & 3171 "specify an attribute Library_Dir", 3172 Data.Location); 3173 end if; 3174 end if; 3175 3176 Projects.Table (Data.Extends).Library := False; 3177 end if; 3178 end; 3179 end if; 3180 3181 pragma Assert (Lib_Dir.Kind = Single); 3182 3183 if Lib_Dir.Value = Empty_String then 3184 3185 if Current_Verbosity = High then 3186 Write_Line ("No library directory"); 3187 end if; 3188 3189 else 3190 -- Find path name, check that it is a directory 3191 3192 Locate_Directory 3193 (Lib_Dir.Value, Data.Display_Directory, 3194 Data.Library_Dir, Data.Display_Library_Dir); 3195 3196 if Data.Library_Dir = No_Name then 3197 3198 -- Get the absolute name of the library directory that 3199 -- does not exist, to report an error. 3200 3201 declare 3202 Dir_Name : constant String := 3203 Get_Name_String (Lib_Dir.Value); 3204 begin 3205 if Is_Absolute_Path (Dir_Name) then 3206 Err_Vars.Error_Msg_Name_1 := Lib_Dir.Value; 3207 3208 else 3209 Get_Name_String (Data.Display_Directory); 3210 3211 if Name_Buffer (Name_Len) /= Directory_Separator then 3212 Name_Len := Name_Len + 1; 3213 Name_Buffer (Name_Len) := Directory_Separator; 3214 end if; 3215 3216 Name_Buffer 3217 (Name_Len + 1 .. Name_Len + Dir_Name'Length) := 3218 Dir_Name; 3219 Name_Len := Name_Len + Dir_Name'Length; 3220 Err_Vars.Error_Msg_Name_1 := Name_Find; 3221 end if; 3222 3223 -- Report the error 3224 3225 Error_Msg 3226 (Project, 3227 "library directory { does not exist", 3228 Lib_Dir.Location); 3229 end; 3230 3231 elsif Data.Library_Dir = Data.Object_Directory then 3232 Error_Msg 3233 (Project, 3234 "library directory cannot be the same " & 3235 "as object directory", 3236 Lib_Dir.Location); 3237 Data.Library_Dir := No_Name; 3238 Data.Display_Library_Dir := No_Name; 3239 3240 else 3241 if Current_Verbosity = High then 3242 Write_Str ("Library directory ="""); 3243 Write_Str (Get_Name_String (Data.Display_Library_Dir)); 3244 Write_Line (""""); 3245 end if; 3246 end if; 3247 end if; 3248 3249 pragma Assert (Lib_Name.Kind = Single); 3250 3251 if Lib_Name.Value = Empty_String then 3252 if Current_Verbosity = High 3253 and then Data.Library_Name = No_Name 3254 then 3255 Write_Line ("No library name"); 3256 end if; 3257 3258 else 3259 -- There is no restriction on the syntax of library names 3260 3261 Data.Library_Name := Lib_Name.Value; 3262 end if; 3263 3264 if Data.Library_Name /= No_Name 3265 and then Current_Verbosity = High 3266 then 3267 Write_Str ("Library name = """); 3268 Write_Str (Get_Name_String (Data.Library_Name)); 3269 Write_Line (""""); 3270 end if; 3271 3272 Data.Library := 3273 Data.Library_Dir /= No_Name 3274 and then 3275 Data.Library_Name /= No_Name; 3276 3277 if Data.Library then 3278 if MLib.Tgt.Support_For_Libraries = MLib.Tgt.None then 3279 Error_Msg 3280 (Project, 3281 "?libraries are not supported on this platform", 3282 Lib_Name.Location); 3283 Data.Library := False; 3284 3285 else 3286 pragma Assert (Lib_Version.Kind = Single); 3287 3288 if Lib_Version.Value = Empty_String then 3289 if Current_Verbosity = High then 3290 Write_Line ("No library version specified"); 3291 end if; 3292 3293 else 3294 Data.Lib_Internal_Name := Lib_Version.Value; 3295 end if; 3296 3297 pragma Assert (The_Lib_Kind.Kind = Single); 3298 3299 if The_Lib_Kind.Value = Empty_String then 3300 if Current_Verbosity = High then 3301 Write_Line ("No library kind specified"); 3302 end if; 3303 3304 else 3305 Get_Name_String (The_Lib_Kind.Value); 3306 3307 declare 3308 Kind_Name : constant String := 3309 To_Lower (Name_Buffer (1 .. Name_Len)); 3310 3311 OK : Boolean := True; 3312 3313 begin 3314 if Kind_Name = "static" then 3315 Data.Library_Kind := Static; 3316 3317 elsif Kind_Name = "dynamic" then 3318 Data.Library_Kind := Dynamic; 3319 3320 elsif Kind_Name = "relocatable" then 3321 Data.Library_Kind := Relocatable; 3322 3323 else 3324 Error_Msg 3325 (Project, 3326 "illegal value for Library_Kind", 3327 The_Lib_Kind.Location); 3328 OK := False; 3329 end if; 3330 3331 if Current_Verbosity = High and then OK then 3332 Write_Str ("Library kind = "); 3333 Write_Line (Kind_Name); 3334 end if; 3335 3336 if Data.Library_Kind /= Static and then 3337 MLib.Tgt.Support_For_Libraries = MLib.Tgt.Static_Only 3338 then 3339 Error_Msg 3340 (Project, 3341 "only static libraries are supported " & 3342 "on this platform", 3343 The_Lib_Kind.Location); 3344 Data.Library := False; 3345 end if; 3346 end; 3347 end if; 3348 3349 if Data.Library and then Current_Verbosity = High then 3350 Write_Line ("This is a library project file"); 3351 end if; 3352 3353 end if; 3354 end if; 3355 end; 3356 3357 if Current_Verbosity = High then 3358 Show_Source_Dirs (Project); 3359 end if; 3360 3361 declare 3362 Naming_Id : constant Package_Id := 3363 Util.Value_Of (Name_Naming, Data.Decl.Packages); 3364 3365 Naming : Package_Element; 3366 3367 begin 3368 -- If there is a package Naming, we will put in Data.Naming 3369 -- what is in this package Naming. 3370 3371 if Naming_Id /= No_Package then 3372 Naming := Packages.Table (Naming_Id); 3373 3374 if Current_Verbosity = High then 3375 Write_Line ("Checking ""Naming""."); 3376 end if; 3377 3378 -- Check Spec_Suffix 3379 3380 declare 3381 Spec_Suffixs : Array_Element_Id := 3382 Util.Value_Of 3383 (Name_Spec_Suffix, 3384 Naming.Decl.Arrays); 3385 Suffix : Array_Element_Id; 3386 Element : Array_Element; 3387 Suffix2 : Array_Element_Id; 3388 3389 begin 3390 -- If some suffixs have been specified, we make sure that 3391 -- for each language for which a default suffix has been 3392 -- specified, there is a suffix specified, either the one 3393 -- in the project file or if there were none, the default. 3394 3395 if Spec_Suffixs /= No_Array_Element then 3396 Suffix := Data.Naming.Spec_Suffix; 3397 3398 while Suffix /= No_Array_Element loop 3399 Element := Array_Elements.Table (Suffix); 3400 Suffix2 := Spec_Suffixs; 3401 3402 while Suffix2 /= No_Array_Element loop 3403 exit when Array_Elements.Table (Suffix2).Index = 3404 Element.Index; 3405 Suffix2 := Array_Elements.Table (Suffix2).Next; 3406 end loop; 3407 3408 -- There is a registered default suffix, but no 3409 -- suffix specified in the project file. 3410 -- Add the default to the array. 3411 3412 if Suffix2 = No_Array_Element then 3413 Array_Elements.Increment_Last; 3414 Array_Elements.Table (Array_Elements.Last) := 3415 (Index => Element.Index, 3416 Index_Case_Sensitive => False, 3417 Value => Element.Value, 3418 Next => Spec_Suffixs); 3419 Spec_Suffixs := Array_Elements.Last; 3420 end if; 3421 3422 Suffix := Element.Next; 3423 end loop; 3424 3425 -- Put the resulting array as the specification suffixs 3426 3427 Data.Naming.Spec_Suffix := Spec_Suffixs; 3428 end if; 3429 end; 3430 3431 declare 3432 Current : Array_Element_Id := Data.Naming.Spec_Suffix; 3433 Element : Array_Element; 3434 3435 begin 3436 while Current /= No_Array_Element loop 3437 Element := Array_Elements.Table (Current); 3438 Get_Name_String (Element.Value.Value); 3439 3440 if Name_Len = 0 then 3441 Error_Msg 3442 (Project, 3443 "Spec_Suffix cannot be empty", 3444 Element.Value.Location); 3445 end if; 3446 3447 Array_Elements.Table (Current) := Element; 3448 Current := Element.Next; 3449 end loop; 3450 end; 3451 3452 -- Check Body_Suffix 3453 3454 declare 3455 Impl_Suffixs : Array_Element_Id := 3456 Util.Value_Of 3457 (Name_Body_Suffix, 3458 Naming.Decl.Arrays); 3459 3460 Suffix : Array_Element_Id; 3461 Element : Array_Element; 3462 Suffix2 : Array_Element_Id; 3463 3464 begin 3465 -- If some suffixs have been specified, we make sure that 3466 -- for each language for which a default suffix has been 3467 -- specified, there is a suffix specified, either the one 3468 -- in the project file or if there were noe, the default. 3469 3470 if Impl_Suffixs /= No_Array_Element then 3471 Suffix := Data.Naming.Body_Suffix; 3472 3473 while Suffix /= No_Array_Element loop 3474 Element := Array_Elements.Table (Suffix); 3475 Suffix2 := Impl_Suffixs; 3476 3477 while Suffix2 /= No_Array_Element loop 3478 exit when Array_Elements.Table (Suffix2).Index = 3479 Element.Index; 3480 Suffix2 := Array_Elements.Table (Suffix2).Next; 3481 end loop; 3482 3483 -- There is a registered default suffix, but no 3484 -- suffix specified in the project file. 3485 -- Add the default to the array. 3486 3487 if Suffix2 = No_Array_Element then 3488 Array_Elements.Increment_Last; 3489 Array_Elements.Table (Array_Elements.Last) := 3490 (Index => Element.Index, 3491 Index_Case_Sensitive => False, 3492 Value => Element.Value, 3493 Next => Impl_Suffixs); 3494 Impl_Suffixs := Array_Elements.Last; 3495 end if; 3496 3497 Suffix := Element.Next; 3498 end loop; 3499 3500 -- Put the resulting array as the implementation suffixs 3501 3502 Data.Naming.Body_Suffix := Impl_Suffixs; 3503 end if; 3504 end; 3505 3506 declare 3507 Current : Array_Element_Id := Data.Naming.Body_Suffix; 3508 Element : Array_Element; 3509 3510 begin 3511 while Current /= No_Array_Element loop 3512 Element := Array_Elements.Table (Current); 3513 Get_Name_String (Element.Value.Value); 3514 3515 if Name_Len = 0 then 3516 Error_Msg 3517 (Project, 3518 "Body_Suffix cannot be empty", 3519 Element.Value.Location); 3520 end if; 3521 3522 Array_Elements.Table (Current) := Element; 3523 Current := Element.Next; 3524 end loop; 3525 end; 3526 3527 -- Get the exceptions, if any 3528 3529 Data.Naming.Specification_Exceptions := 3530 Util.Value_Of 3531 (Name_Specification_Exceptions, 3532 In_Arrays => Naming.Decl.Arrays); 3533 3534 Data.Naming.Implementation_Exceptions := 3535 Util.Value_Of 3536 (Name_Implementation_Exceptions, 3537 In_Arrays => Naming.Decl.Arrays); 3538 end if; 3539 end; 3540 3541 Projects.Table (Project) := Data; 3542 end Language_Independent_Check; 3543 3544 ---------------------- 3545 -- Locate_Directory -- 3546 ---------------------- 3547 3548 procedure Locate_Directory 3549 (Name : Name_Id; 3550 Parent : Name_Id; 3551 Dir : out Name_Id; 3552 Display : out Name_Id) 3553 is 3554 The_Name : constant String := Get_Name_String (Name); 3555 The_Parent : constant String := 3556 Get_Name_String (Parent) & Directory_Separator; 3557 The_Parent_Last : constant Natural := 3558 Compute_Directory_Last (The_Parent); 3559 3560 begin 3561 if Current_Verbosity = High then 3562 Write_Str ("Locate_Directory ("""); 3563 Write_Str (The_Name); 3564 Write_Str (""", """); 3565 Write_Str (The_Parent); 3566 Write_Line (""")"); 3567 end if; 3568 3569 Dir := No_Name; 3570 Display := No_Name; 3571 3572 if Is_Absolute_Path (The_Name) then 3573 if Is_Directory (The_Name) then 3574 declare 3575 Normed : constant String := 3576 Normalize_Pathname (The_Name); 3577 3578 begin 3579 Name_Len := Normed'Length; 3580 Name_Buffer (1 .. Name_Len) := Normed; 3581 Display := Name_Find; 3582 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 3583 Dir := Name_Find; 3584 end; 3585 end if; 3586 3587 else 3588 declare 3589 Full_Path : constant String := 3590 The_Parent (The_Parent'First .. The_Parent_Last) & 3591 The_Name; 3592 3593 begin 3594 if Is_Directory (Full_Path) then 3595 declare 3596 Normed : constant String := 3597 Normalize_Pathname (Full_Path); 3598 3599 begin 3600 Name_Len := Normed'Length; 3601 Name_Buffer (1 .. Name_Len) := Normed; 3602 Display := Name_Find; 3603 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 3604 Dir := Name_Find; 3605 end; 3606 end if; 3607 end; 3608 end if; 3609 end Locate_Directory; 3610 3611 ------------------ 3612 -- Path_Name_Of -- 3613 ------------------ 3614 3615 function Path_Name_Of 3616 (File_Name : Name_Id; 3617 Directory : Name_Id) return String 3618 is 3619 Result : String_Access; 3620 The_Directory : constant String := Get_Name_String (Directory); 3621 3622 begin 3623 Get_Name_String (File_Name); 3624 Result := Locate_Regular_File 3625 (File_Name => Name_Buffer (1 .. Name_Len), 3626 Path => The_Directory); 3627 3628 if Result = null then 3629 return ""; 3630 else 3631 Canonical_Case_File_Name (Result.all); 3632 return Result.all; 3633 end if; 3634 end Path_Name_Of; 3635 3636 --------------------- 3637 -- Project_Extends -- 3638 --------------------- 3639 3640 function Project_Extends 3641 (Extending : Project_Id; 3642 Extended : Project_Id) return Boolean 3643 is 3644 Current : Project_Id := Extending; 3645 begin 3646 loop 3647 if Current = No_Project then 3648 return False; 3649 3650 elsif Current = Extended then 3651 return True; 3652 end if; 3653 3654 Current := Projects.Table (Current).Extends; 3655 end loop; 3656 end Project_Extends; 3657 3658 ------------------- 3659 -- Record_Source -- 3660 ------------------- 3661 3662 procedure Record_Source 3663 (File_Name : Name_Id; 3664 Path_Name : Name_Id; 3665 Project : Project_Id; 3666 Data : in out Project_Data; 3667 Location : Source_Ptr; 3668 Current_Source : in out String_List_Id; 3669 Source_Recorded : in out Boolean) 3670 is 3671 Canonical_File_Name : Name_Id; 3672 Canonical_Path_Name : Name_Id; 3673 Unit_Name : Name_Id; 3674 Unit_Kind : Spec_Or_Body; 3675 Needs_Pragma : Boolean; 3676 3677 The_Location : Source_Ptr := Location; 3678 Previous_Source : constant String_List_Id := Current_Source; 3679 Except_Name : Name_Id := No_Name; 3680 3681 begin 3682 Get_Name_String (File_Name); 3683 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 3684 Canonical_File_Name := Name_Find; 3685 Get_Name_String (Path_Name); 3686 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 3687 Canonical_Path_Name := Name_Find; 3688 3689 -- Find out the unit name, the unit kind and if it needs 3690 -- a specific SFN pragma. 3691 3692 Get_Unit 3693 (Canonical_File_Name => Canonical_File_Name, 3694 Naming => Data.Naming, 3695 Unit_Name => Unit_Name, 3696 Unit_Kind => Unit_Kind, 3697 Needs_Pragma => Needs_Pragma); 3698 3699 if Unit_Name = No_Name then 3700 if Current_Verbosity = High then 3701 Write_Str (" """); 3702 Write_Str (Get_Name_String (Canonical_File_Name)); 3703 Write_Line (""" is not a valid source file name (ignored)."); 3704 end if; 3705 3706 else 3707 -- Check to see if the source has been hidden by an exception, 3708 -- but only if it is not an exception. 3709 3710 if not Needs_Pragma then 3711 Except_Name := 3712 Reverse_Naming_Exceptions.Get ((Unit_Kind, Unit_Name)); 3713 3714 if Except_Name /= No_Name then 3715 if Current_Verbosity = High then 3716 Write_Str (" """); 3717 Write_Str (Get_Name_String (Canonical_File_Name)); 3718 Write_Str (""" contains a unit that is found in """); 3719 Write_Str (Get_Name_String (Except_Name)); 3720 Write_Line (""" (ignored)."); 3721 end if; 3722 3723 -- The file is not included in the source of the project, 3724 -- because it is hidden by the exception. 3725 -- So, there is nothing else to do. 3726 3727 return; 3728 end if; 3729 end if; 3730 3731 -- Put the file name in the list of sources of the project 3732 3733 String_Elements.Increment_Last; 3734 String_Elements.Table (String_Elements.Last) := 3735 (Value => Canonical_File_Name, 3736 Display_Value => File_Name, 3737 Location => No_Location, 3738 Flag => False, 3739 Next => Nil_String); 3740 3741 if Current_Source = Nil_String then 3742 Data.Sources := String_Elements.Last; 3743 3744 else 3745 String_Elements.Table (Current_Source).Next := 3746 String_Elements.Last; 3747 end if; 3748 3749 Current_Source := String_Elements.Last; 3750 3751 -- Put the unit in unit list 3752 3753 declare 3754 The_Unit : Unit_Id := Units_Htable.Get (Unit_Name); 3755 The_Unit_Data : Unit_Data; 3756 3757 begin 3758 if Current_Verbosity = High then 3759 Write_Str ("Putting "); 3760 Write_Str (Get_Name_String (Unit_Name)); 3761 Write_Line (" in the unit list."); 3762 end if; 3763 3764 -- The unit is already in the list, but may be it is 3765 -- only the other unit kind (spec or body), or what is 3766 -- in the unit list is a unit of a project we are extending. 3767 3768 if The_Unit /= Prj.Com.No_Unit then 3769 The_Unit_Data := Units.Table (The_Unit); 3770 3771 if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name 3772 or else Project_Extends 3773 (Data.Extends, 3774 The_Unit_Data.File_Names (Unit_Kind).Project) 3775 then 3776 if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then 3777 Remove_Forbidden_File_Name 3778 (The_Unit_Data.File_Names (Unit_Kind).Name); 3779 end if; 3780 3781 The_Unit_Data.File_Names (Unit_Kind) := 3782 (Name => Canonical_File_Name, 3783 Display_Name => File_Name, 3784 Path => Canonical_Path_Name, 3785 Display_Path => Path_Name, 3786 Project => Project, 3787 Needs_Pragma => Needs_Pragma); 3788 Units.Table (The_Unit) := The_Unit_Data; 3789 Source_Recorded := True; 3790 3791 elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project 3792 and then (Data.Known_Order_Of_Source_Dirs or else 3793 The_Unit_Data.File_Names (Unit_Kind).Path = 3794 Canonical_Path_Name) 3795 then 3796 if Previous_Source = Nil_String then 3797 Data.Sources := Nil_String; 3798 else 3799 String_Elements.Table (Previous_Source).Next := 3800 Nil_String; 3801 String_Elements.Decrement_Last; 3802 end if; 3803 3804 Current_Source := Previous_Source; 3805 3806 else 3807 -- It is an error to have two units with the same name 3808 -- and the same kind (spec or body). 3809 3810 if The_Location = No_Location then 3811 The_Location := Projects.Table (Project).Location; 3812 end if; 3813 3814 Err_Vars.Error_Msg_Name_1 := Unit_Name; 3815 Error_Msg (Project, "duplicate source {", The_Location); 3816 3817 Err_Vars.Error_Msg_Name_1 := 3818 Projects.Table 3819 (The_Unit_Data.File_Names (Unit_Kind).Project).Name; 3820 Err_Vars.Error_Msg_Name_2 := 3821 The_Unit_Data.File_Names (Unit_Kind).Path; 3822 Error_Msg (Project, "\ project file {, {", The_Location); 3823 3824 Err_Vars.Error_Msg_Name_1 := Projects.Table (Project).Name; 3825 Err_Vars.Error_Msg_Name_2 := Canonical_Path_Name; 3826 Error_Msg (Project, "\ project file {, {", The_Location); 3827 3828 end if; 3829 3830 -- It is a new unit, create a new record 3831 3832 else 3833 Units.Increment_Last; 3834 The_Unit := Units.Last; 3835 Units_Htable.Set (Unit_Name, The_Unit); 3836 The_Unit_Data.Name := Unit_Name; 3837 The_Unit_Data.File_Names (Unit_Kind) := 3838 (Name => Canonical_File_Name, 3839 Display_Name => File_Name, 3840 Path => Canonical_Path_Name, 3841 Display_Path => Path_Name, 3842 Project => Project, 3843 Needs_Pragma => Needs_Pragma); 3844 Units.Table (The_Unit) := The_Unit_Data; 3845 Source_Recorded := True; 3846 end if; 3847 end; 3848 end if; 3849 end Record_Source; 3850 3851 ---------------------- 3852 -- Show_Source_Dirs -- 3853 ---------------------- 3854 3855 procedure Show_Source_Dirs (Project : Project_Id) is 3856 Current : String_List_Id := Projects.Table (Project).Source_Dirs; 3857 Element : String_Element; 3858 3859 begin 3860 Write_Line ("Source_Dirs:"); 3861 3862 while Current /= Nil_String loop 3863 Element := String_Elements.Table (Current); 3864 Write_Str (" "); 3865 Write_Line (Get_Name_String (Element.Value)); 3866 Current := Element.Next; 3867 end loop; 3868 3869 Write_Line ("end Source_Dirs."); 3870 end Show_Source_Dirs; 3871 3872end Prj.Nmsc; 3873