1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . M A K R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-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 Csets; 28with Namet; use Namet; 29with Opt; 30with Output; 31with Osint; use Osint; 32with Prj; use Prj; 33with Prj.Com; 34with Prj.Part; 35with Prj.PP; 36with Prj.Tree; use Prj.Tree; 37with Snames; use Snames; 38with Table; use Table; 39 40with Ada.Characters.Handling; use Ada.Characters.Handling; 41with GNAT.Directory_Operations; use GNAT.Directory_Operations; 42with GNAT.Expect; use GNAT.Expect; 43with GNAT.OS_Lib; use GNAT.OS_Lib; 44with GNAT.Regexp; use GNAT.Regexp; 45with GNAT.Regpat; use GNAT.Regpat; 46 47package body Prj.Makr is 48 49 Non_Empty_Node : constant Project_Node_Id := 1; 50 -- Used for the With_Clause of the naming project 51 52 type Matched_Type is (True, False, Excluded); 53 54 Naming_File_Suffix : constant String := "_naming"; 55 Source_List_File_Suffix : constant String := "_source_list.txt"; 56 57 Output_FD : File_Descriptor; 58 -- To save the project file and its naming project file. 59 60 procedure Write_Eol; 61 -- Output an empty line. 62 63 procedure Write_A_Char (C : Character); 64 -- Write one character to Output_FD 65 66 procedure Write_A_String (S : String); 67 -- Write a String to Output_FD 68 69 package Processed_Directories is new Table.Table 70 (Table_Component_Type => String_Access, 71 Table_Index_Type => Natural, 72 Table_Low_Bound => 0, 73 Table_Initial => 10, 74 Table_Increment => 10, 75 Table_Name => "Prj.Makr.Processed_Directories"); 76 77 ---------- 78 -- Make -- 79 ---------- 80 81 procedure Make 82 (File_Path : String; 83 Project_File : Boolean; 84 Directories : Argument_List; 85 Name_Patterns : Argument_List; 86 Excluded_Patterns : Argument_List; 87 Foreign_Patterns : Argument_List; 88 Preproc_Switches : Argument_List; 89 Very_Verbose : Boolean) 90 is 91 Path_Name : String (1 .. File_Path'Length + 92 Project_File_Extension'Length); 93 Path_Last : Natural := File_Path'Length; 94 95 Directory_Last : Natural := 0; 96 97 Output_Name : String (Path_Name'Range); 98 Output_Name_Last : Natural; 99 Output_Name_Id : Name_Id; 100 101 Project_Node : Project_Node_Id := Empty_Node; 102 Project_Declaration : Project_Node_Id := Empty_Node; 103 Source_Dirs_List : Project_Node_Id := Empty_Node; 104 Current_Source_Dir : Project_Node_Id := Empty_Node; 105 106 Project_Naming_Node : Project_Node_Id := Empty_Node; 107 Project_Naming_Decl : Project_Node_Id := Empty_Node; 108 Naming_Package : Project_Node_Id := Empty_Node; 109 110 Project_Naming_File_Name : String (1 .. Output_Name'Length + 111 Naming_File_Suffix'Length); 112 113 Project_Naming_Last : Natural; 114 Project_Naming_Id : Name_Id := No_Name; 115 116 Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp; 117 Regular_Expressions : array (Name_Patterns'Range) of Regexp; 118 Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp; 119 120 Source_List_Path : String (1 .. Output_Name'Length + 121 Source_List_File_Suffix'Length); 122 Source_List_Last : Natural; 123 124 Source_List_FD : File_Descriptor; 125 126 Matcher : constant Pattern_Matcher := 127 Compile (Expression => "expected|Unit.*\)|No such"); 128 129 Args : Argument_List (1 .. Preproc_Switches'Length + 6); 130-- (1 => new String'("-c"), 131-- 2 => new String'("-gnats"), 132-- 3 => new String'("-gnatu"), 133-- 4 => new String'("-x"), 134-- 5 => new String'("ada"), 135-- 6 => null); 136 137 type SFN_Pragma is record 138 Unit : String_Access; 139 File : String_Access; 140 Spec : Boolean; 141 end record; 142 143 package SFN_Pragmas is new Table.Table 144 (Table_Component_Type => SFN_Pragma, 145 Table_Index_Type => Natural, 146 Table_Low_Bound => 0, 147 Table_Initial => 50, 148 Table_Increment => 50, 149 Table_Name => "Prj.Makr.SFN_Pragmas"); 150 151 procedure Process_Directory (Dir_Name : String; Recursively : Boolean); 152 -- Look for Ada and foreign sources in a directory, according to the 153 -- patterns. When Recursively is True, after looking for sources in 154 -- Dir_Name, look also in its subdirectories, if any. 155 156 ----------------------- 157 -- Process_Directory -- 158 ----------------------- 159 160 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is 161 Matched : Matched_Type := False; 162 Str : String (1 .. 2_000); 163 Last : Natural; 164 Dir : Dir_Type; 165 Process : Boolean := True; 166 167 begin 168 if Opt.Verbose_Mode then 169 Output.Write_Str ("Processing directory """); 170 Output.Write_Str (Dir_Name); 171 Output.Write_Line (""""); 172 end if; 173 174 -- Avoid processing several times the same directory. 175 176 for Index in 1 .. Processed_Directories.Last loop 177 if Processed_Directories.Table (Index).all = Dir_Name then 178 Process := False; 179 exit; 180 end if; 181 end loop; 182 183 if Process then 184 Processed_Directories. Increment_Last; 185 Processed_Directories.Table (Processed_Directories.Last) := 186 new String'(Dir_Name); 187 -- Get the source file names from the directory. 188 -- Fails if the directory does not exist. 189 190 begin 191 Open (Dir, Dir_Name); 192 193 exception 194 when Directory_Error => 195 Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); 196 end; 197 198 -- Process each regular file in the directory 199 200 loop 201 Read (Dir, Str, Last); 202 exit when Last = 0; 203 204 if Is_Regular_File 205 (Dir_Name & Directory_Separator & Str (1 .. Last)) 206 then 207 Matched := True; 208 209 -- First, check if the file name matches at least one of 210 -- the excluded expressions; 211 212 for Index in Excluded_Expressions'Range loop 213 if 214 Match (Str (1 .. Last), Excluded_Expressions (Index)) 215 then 216 Matched := Excluded; 217 exit; 218 end if; 219 end loop; 220 221 -- If it does not match any of the excluded expressions, 222 -- check if the file name matches at least one of the 223 -- regular expressions. 224 225 if Matched = True then 226 Matched := False; 227 228 for Index in Regular_Expressions'Range loop 229 if 230 Match (Str (1 .. Last), Regular_Expressions (Index)) 231 then 232 Matched := True; 233 exit; 234 end if; 235 end loop; 236 end if; 237 238 if Very_Verbose 239 or else (Matched = True and then Opt.Verbose_Mode) 240 then 241 Output.Write_Str (" Checking """); 242 Output.Write_Str (Str (1 .. Last)); 243 Output.Write_Str (""": "); 244 end if; 245 246 -- If the file name matches one of the regular expressions, 247 -- parse it to get its unit name. 248 249 if Matched = True then 250 declare 251 PD : Process_Descriptor; 252 Result : Expect_Match; 253 254 begin 255 Args (Args'Last) := new String' 256 (Dir_Name & 257 Directory_Separator & 258 Str (1 .. Last)); 259 260 begin 261 Non_Blocking_Spawn 262 (PD, "gcc", Args, Err_To_Out => True); 263 Expect (PD, Result, Matcher); 264 265 exception 266 when Process_Died => 267 if Opt.Verbose_Mode then 268 Output.Write_Str ("(process died) "); 269 end if; 270 271 Result := Expect_Timeout; 272 end; 273 274 if Result /= Expect_Timeout then 275 276 -- If we got a unit name, this is a valid source 277 -- file. 278 279 declare 280 S : constant String := Expect_Out_Match (PD); 281 282 begin 283 if S'Length >= 13 284 and then S (S'First .. S'First + 3) = "Unit" 285 then 286 if Opt.Verbose_Mode then 287 Output.Write_Str 288 (S (S'Last - 4 .. S'Last - 1)); 289 Output.Write_Str (" of "); 290 Output.Write_Line 291 (S (S'First + 5 .. S'Last - 7)); 292 end if; 293 294 if Project_File then 295 296 -- Add the corresponding attribute in the 297 -- Naming package of the naming project. 298 299 declare 300 Decl_Item : constant Project_Node_Id := 301 Default_Project_Node 302 (Of_Kind => 303 N_Declarative_Item); 304 305 Attribute : constant Project_Node_Id := 306 Default_Project_Node 307 (Of_Kind => 308 N_Attribute_Declaration); 309 310 Expression : constant Project_Node_Id := 311 Default_Project_Node 312 (Of_Kind => N_Expression, 313 And_Expr_Kind => Single); 314 315 Term : constant Project_Node_Id := 316 Default_Project_Node 317 (Of_Kind => N_Term, 318 And_Expr_Kind => Single); 319 320 Value : constant Project_Node_Id := 321 Default_Project_Node 322 (Of_Kind => N_Literal_String, 323 And_Expr_Kind => Single); 324 325 begin 326 Set_Next_Declarative_Item 327 (Decl_Item, 328 To => First_Declarative_Item_Of 329 (Naming_Package)); 330 Set_First_Declarative_Item_Of 331 (Naming_Package, To => Decl_Item); 332 Set_Current_Item_Node 333 (Decl_Item, To => Attribute); 334 335 if 336 S (S'Last - 5 .. S'Last) = "(spec)" 337 then 338 Set_Name_Of 339 (Attribute, To => Name_Spec); 340 else 341 Set_Name_Of 342 (Attribute, 343 To => Name_Body); 344 end if; 345 346 Name_Len := S'Last - S'First - 11; 347 Name_Buffer (1 .. Name_Len) := 348 (To_Lower 349 (S (S'First + 5 .. S'Last - 7))); 350 Set_Associative_Array_Index_Of 351 (Attribute, To => Name_Find); 352 353 Set_Expression_Of 354 (Attribute, To => Expression); 355 Set_First_Term (Expression, To => Term); 356 Set_Current_Term (Term, To => Value); 357 358 Name_Len := Last; 359 Name_Buffer (1 .. Name_Len) := 360 Str (1 .. Last); 361 Set_String_Value_Of 362 (Value, To => Name_Find); 363 end; 364 365 -- Add source file name to source list 366 -- file. 367 368 Last := Last + 1; 369 Str (Last) := ASCII.LF; 370 371 if Write (Source_List_FD, 372 Str (1)'Address, 373 Last) /= Last 374 then 375 Prj.Com.Fail ("disk full"); 376 end if; 377 else 378 -- Add an entry in the SFN_Pragmas table 379 380 SFN_Pragmas.Increment_Last; 381 SFN_Pragmas.Table (SFN_Pragmas.Last) := 382 (Unit => new String' 383 (S (S'First + 5 .. S'Last - 7)), 384 File => new String'(Str (1 .. Last)), 385 Spec => S (S'Last - 5 .. S'Last) 386 = "(spec)"); 387 end if; 388 389 else 390 if Opt.Verbose_Mode then 391 Output.Write_Line ("not a unit"); 392 end if; 393 end if; 394 end; 395 396 else 397 if Opt.Verbose_Mode then 398 Output.Write_Line ("not a unit"); 399 end if; 400 end if; 401 402 Close (PD); 403 end; 404 405 else 406 if Matched = False then 407 -- Look if this is a foreign source 408 409 for Index in Foreign_Expressions'Range loop 410 if Match (Str (1 .. Last), 411 Foreign_Expressions (Index)) 412 then 413 Matched := True; 414 exit; 415 end if; 416 end loop; 417 end if; 418 419 if Very_Verbose then 420 case Matched is 421 when False => 422 Output.Write_Line ("no match"); 423 424 when Excluded => 425 Output.Write_Line ("excluded"); 426 427 when True => 428 Output.Write_Line ("foreign source"); 429 end case; 430 end if; 431 432 if Project_File and Matched = True then 433 434 -- Add source file name to source list file 435 436 Last := Last + 1; 437 Str (Last) := ASCII.LF; 438 439 if Write (Source_List_FD, 440 Str (1)'Address, 441 Last) /= Last 442 then 443 Prj.Com.Fail ("disk full"); 444 end if; 445 end if; 446 end if; 447 end if; 448 end loop; 449 450 Close (Dir); 451 end if; 452 453 -- If Recursively is True, call itself for each subdirectory. 454 -- We do that, even when this directory has already been processed, 455 -- because all of its subdirectories may not have been processed. 456 457 if Recursively then 458 Open (Dir, Dir_Name); 459 460 loop 461 Read (Dir, Str, Last); 462 exit when Last = 0; 463 464 -- Do not call itself for "." or ".." 465 466 if Is_Directory 467 (Dir_Name & Directory_Separator & Str (1 .. Last)) 468 and then Str (1 .. Last) /= "." 469 and then Str (1 .. Last) /= ".." 470 then 471 Process_Directory 472 (Dir_Name & Directory_Separator & Str (1 .. Last), 473 Recursively => True); 474 end if; 475 end loop; 476 477 Close (Dir); 478 end if; 479 end Process_Directory; 480 481 -- Start of processing for Make 482 483 begin 484 -- Do some needed initializations 485 486 Csets.Initialize; 487 Namet.Initialize; 488 Snames.Initialize; 489 Prj.Initialize; 490 491 SFN_Pragmas.Set_Last (0); 492 493 Processed_Directories.Set_Last (0); 494 495 -- Initialize the compiler switches 496 497 Args (1) := new String'("-c"); 498 Args (2) := new String'("-gnats"); 499 Args (3) := new String'("-gnatu"); 500 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches; 501 Args (4 + Preproc_Switches'Length) := new String'("-x"); 502 Args (5 + Preproc_Switches'Length) := new String'("ada"); 503 504 -- Get the path and file names 505 506 if File_Names_Case_Sensitive then 507 Path_Name (1 .. Path_Last) := File_Path; 508 else 509 Path_Name (1 .. Path_Last) := To_Lower (File_Path); 510 end if; 511 512 Path_Name (Path_Last + 1 .. Path_Name'Last) := 513 Project_File_Extension; 514 515 -- Get the end of directory information, if any 516 517 for Index in reverse 1 .. Path_Last loop 518 if Path_Name (Index) = Directory_Separator then 519 Directory_Last := Index; 520 exit; 521 end if; 522 end loop; 523 524 if Project_File then 525 if Path_Last < Project_File_Extension'Length + 1 526 or else Path_Name 527 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last) 528 /= Project_File_Extension 529 then 530 Path_Last := Path_Name'Last; 531 end if; 532 533 Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last)); 534 Output_Name_Last := Path_Last - Project_File_Extension'Length; 535 536 if Directory_Last /= 0 then 537 Output_Name (1 .. Output_Name_Last - Directory_Last) := 538 Output_Name (Directory_Last + 1 .. Output_Name_Last); 539 Output_Name_Last := Output_Name_Last - Directory_Last; 540 end if; 541 542 -- Get the project name id 543 544 Name_Len := Output_Name_Last; 545 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len); 546 Output_Name_Id := Name_Find; 547 548 -- Create the project naming file name 549 550 Project_Naming_Last := Output_Name_Last; 551 Project_Naming_File_Name (1 .. Project_Naming_Last) := 552 Output_Name (1 .. Project_Naming_Last); 553 Project_Naming_File_Name 554 (Project_Naming_Last + 1 .. 555 Project_Naming_Last + Naming_File_Suffix'Length) := 556 Naming_File_Suffix; 557 Project_Naming_Last := 558 Project_Naming_Last + Naming_File_Suffix'Length; 559 560 -- Get the project naming id 561 562 Name_Len := Project_Naming_Last; 563 Name_Buffer (1 .. Name_Len) := 564 Project_Naming_File_Name (1 .. Name_Len); 565 Project_Naming_Id := Name_Find; 566 567 Project_Naming_File_Name 568 (Project_Naming_Last + 1 .. 569 Project_Naming_Last + Project_File_Extension'Length) := 570 Project_File_Extension; 571 Project_Naming_Last := 572 Project_Naming_Last + Project_File_Extension'Length; 573 574 -- Create the source list file name 575 576 Source_List_Last := Output_Name_Last; 577 Source_List_Path (1 .. Source_List_Last) := 578 Output_Name (1 .. Source_List_Last); 579 Source_List_Path 580 (Source_List_Last + 1 .. 581 Source_List_Last + Source_List_File_Suffix'Length) := 582 Source_List_File_Suffix; 583 Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length; 584 585 -- Add the project file extension to the project name 586 587 Output_Name 588 (Output_Name_Last + 1 .. 589 Output_Name_Last + Project_File_Extension'Length) := 590 Project_File_Extension; 591 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; 592 end if; 593 594 -- Change the current directory to the directory of the project file, 595 -- if any directory information is specified. 596 597 if Directory_Last /= 0 then 598 begin 599 Change_Dir (Path_Name (1 .. Directory_Last)); 600 exception 601 when Directory_Error => 602 Prj.Com.Fail 603 ("unknown directory """, 604 Path_Name (1 .. Directory_Last), 605 """"); 606 end; 607 end if; 608 609 if Project_File then 610 611 -- Delete the source list file, if it already exists 612 613 declare 614 Discard : Boolean; 615 616 begin 617 Delete_File 618 (Source_List_Path (1 .. Source_List_Last), 619 Success => Discard); 620 end; 621 622 -- And create a new source list file. 623 -- Fail if file cannot be created. 624 625 Source_List_FD := Create_New_File 626 (Name => Source_List_Path (1 .. Source_List_Last), 627 Fmode => Text); 628 629 if Source_List_FD = Invalid_FD then 630 Prj.Com.Fail 631 ("cannot create file """, 632 Source_List_Path (1 .. Source_List_Last), 633 """"); 634 end if; 635 end if; 636 637 -- Compile the regular expressions. Fails immediately if any of 638 -- the specified strings is in error. 639 640 for Index in Excluded_Expressions'Range loop 641 if Very_Verbose then 642 Output.Write_Str ("Excluded pattern: """); 643 Output.Write_Str (Excluded_Patterns (Index).all); 644 Output.Write_Line (""""); 645 end if; 646 647 begin 648 Excluded_Expressions (Index) := 649 Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); 650 651 exception 652 when Error_In_Regexp => 653 Prj.Com.Fail 654 ("invalid regular expression """, 655 Excluded_Patterns (Index).all, 656 """"); 657 end; 658 end loop; 659 660 for Index in Foreign_Expressions'Range loop 661 if Very_Verbose then 662 Output.Write_Str ("Foreign pattern: """); 663 Output.Write_Str (Foreign_Patterns (Index).all); 664 Output.Write_Line (""""); 665 end if; 666 667 begin 668 Foreign_Expressions (Index) := 669 Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); 670 671 exception 672 when Error_In_Regexp => 673 Prj.Com.Fail 674 ("invalid regular expression """, 675 Foreign_Patterns (Index).all, 676 """"); 677 end; 678 end loop; 679 680 for Index in Regular_Expressions'Range loop 681 if Very_Verbose then 682 Output.Write_Str ("Pattern: """); 683 Output.Write_Str (Name_Patterns (Index).all); 684 Output.Write_Line (""""); 685 end if; 686 687 begin 688 Regular_Expressions (Index) := 689 Compile (Pattern => Name_Patterns (Index).all, Glob => True); 690 691 exception 692 when Error_In_Regexp => 693 Prj.Com.Fail 694 ("invalid regular expression """, 695 Name_Patterns (Index).all, 696 """"); 697 end; 698 end loop; 699 700 if Project_File then 701 if Opt.Verbose_Mode then 702 Output.Write_Str ("Naming project file name is """); 703 Output.Write_Str 704 (Project_Naming_File_Name (1 .. Project_Naming_Last)); 705 Output.Write_Line (""""); 706 end if; 707 708 -- If there is already a project file with the specified name, 709 -- parse it to get the components that are not automatically 710 -- generated. 711 712 if Is_Regular_File (Output_Name (1 .. Output_Name_Last)) then 713 if Opt.Verbose_Mode then 714 Output.Write_Str ("Parsing already existing project file """); 715 Output.Write_Str (Output_Name (1 .. Output_Name_Last)); 716 Output.Write_Line (""""); 717 end if; 718 719 Part.Parse 720 (Project => Project_Node, 721 Project_File_Name => Output_Name (1 .. Output_Name_Last), 722 Always_Errout_Finalize => False); 723 724 -- If parsing was successful, remove the components that are 725 -- automatically generated, if any, so that they will be 726 -- unconditionally added later. 727 728 if Project_Node /= Empty_Node then 729 730 -- Remove the with clause for the naming project file 731 732 declare 733 With_Clause : Project_Node_Id := 734 First_With_Clause_Of (Project_Node); 735 Previous : Project_Node_Id := Empty_Node; 736 737 begin 738 while With_Clause /= Empty_Node loop 739 if Tree.Name_Of (With_Clause) = Project_Naming_Id then 740 if Previous = Empty_Node then 741 Set_First_With_Clause_Of 742 (Project_Node, 743 To => Next_With_Clause_Of (With_Clause)); 744 else 745 Set_Next_With_Clause_Of 746 (Previous, 747 To => Next_With_Clause_Of (With_Clause)); 748 end if; 749 750 exit; 751 end if; 752 753 Previous := With_Clause; 754 With_Clause := Next_With_Clause_Of (With_Clause); 755 end loop; 756 end; 757 758 -- Remove attribute declarations of Source_Files, 759 -- Source_List_File, Source_Dirs, and the declaration of 760 -- package Naming, if they exist. 761 762 declare 763 Declaration : Project_Node_Id := 764 First_Declarative_Item_Of 765 (Project_Declaration_Of 766 (Project_Node)); 767 Previous : Project_Node_Id := Empty_Node; 768 Current_Node : Project_Node_Id := Empty_Node; 769 770 begin 771 while Declaration /= Empty_Node loop 772 Current_Node := Current_Item_Node (Declaration); 773 774 if (Kind_Of (Current_Node) = N_Attribute_Declaration 775 and then 776 (Tree.Name_Of (Current_Node) = Name_Source_Files 777 or else Tree.Name_Of (Current_Node) = 778 Name_Source_List_File 779 or else Tree.Name_Of (Current_Node) = 780 Name_Source_Dirs)) 781 or else 782 (Kind_Of (Current_Node) = N_Package_Declaration 783 and then Tree.Name_Of (Current_Node) = Name_Naming) 784 then 785 if Previous = Empty_Node then 786 Set_First_Declarative_Item_Of 787 (Project_Declaration_Of (Project_Node), 788 To => Next_Declarative_Item (Declaration)); 789 790 else 791 Set_Next_Declarative_Item 792 (Previous, 793 To => Next_Declarative_Item (Declaration)); 794 end if; 795 796 else 797 Previous := Declaration; 798 end if; 799 800 Declaration := Next_Declarative_Item (Declaration); 801 end loop; 802 end; 803 end if; 804 end if; 805 806 -- If there were no already existing project file, or if the parsing 807 -- was unsuccessful, create an empty project node with the correct 808 -- name and its project declaration node. 809 810 if Project_Node = Empty_Node then 811 Project_Node := Default_Project_Node (Of_Kind => N_Project); 812 Set_Name_Of (Project_Node, To => Output_Name_Id); 813 Set_Project_Declaration_Of 814 (Project_Node, 815 To => Default_Project_Node (Of_Kind => N_Project_Declaration)); 816 817 end if; 818 819 -- Create the naming project node, and add an attribute declaration 820 -- for Source_Files as an empty list, to indicate there are no 821 -- sources in the naming project. 822 823 Project_Naming_Node := Default_Project_Node (Of_Kind => N_Project); 824 Set_Name_Of (Project_Naming_Node, To => Project_Naming_Id); 825 Project_Naming_Decl := 826 Default_Project_Node (Of_Kind => N_Project_Declaration); 827 Set_Project_Declaration_Of (Project_Naming_Node, Project_Naming_Decl); 828 Naming_Package := 829 Default_Project_Node (Of_Kind => N_Package_Declaration); 830 Set_Name_Of (Naming_Package, To => Name_Naming); 831 832 declare 833 Decl_Item : constant Project_Node_Id := 834 Default_Project_Node (Of_Kind => N_Declarative_Item); 835 836 Attribute : constant Project_Node_Id := 837 Default_Project_Node 838 (Of_Kind => N_Attribute_Declaration, 839 And_Expr_Kind => List); 840 841 Expression : constant Project_Node_Id := 842 Default_Project_Node 843 (Of_Kind => N_Expression, 844 And_Expr_Kind => List); 845 846 Term : constant Project_Node_Id := 847 Default_Project_Node 848 (Of_Kind => N_Term, 849 And_Expr_Kind => List); 850 851 Empty_List : constant Project_Node_Id := 852 Default_Project_Node 853 (Of_Kind => N_Literal_String_List); 854 855 begin 856 Set_First_Declarative_Item_Of 857 (Project_Naming_Decl, To => Decl_Item); 858 Set_Next_Declarative_Item (Decl_Item, Naming_Package); 859 Set_Current_Item_Node (Decl_Item, To => Attribute); 860 Set_Name_Of (Attribute, To => Name_Source_Files); 861 Set_Expression_Of (Attribute, To => Expression); 862 Set_First_Term (Expression, To => Term); 863 Set_Current_Term (Term, To => Empty_List); 864 end; 865 866 -- Add a with clause on the naming project in the main project 867 868 declare 869 With_Clause : constant Project_Node_Id := 870 Default_Project_Node (Of_Kind => N_With_Clause); 871 872 begin 873 Set_Next_With_Clause_Of 874 (With_Clause, To => First_With_Clause_Of (Project_Node)); 875 Set_First_With_Clause_Of (Project_Node, To => With_Clause); 876 Set_Name_Of (With_Clause, To => Project_Naming_Id); 877 878 -- We set the project node to something different than 879 -- Empty_Node, so that Prj.PP does not generate a limited 880 -- with clause. 881 882 Set_Project_Node_Of (With_Clause, Non_Empty_Node); 883 884 Name_Len := Project_Naming_Last; 885 Name_Buffer (1 .. Name_Len) := 886 Project_Naming_File_Name (1 .. Project_Naming_Last); 887 Set_String_Value_Of (With_Clause, To => Name_Find); 888 end; 889 890 Project_Declaration := Project_Declaration_Of (Project_Node); 891 892 -- Add a renaming declaration for package Naming in the main project 893 894 declare 895 Decl_Item : constant Project_Node_Id := 896 Default_Project_Node (Of_Kind => N_Declarative_Item); 897 898 Naming : constant Project_Node_Id := 899 Default_Project_Node (Of_Kind => N_Package_Declaration); 900 begin 901 Set_Next_Declarative_Item 902 (Decl_Item, 903 To => First_Declarative_Item_Of (Project_Declaration)); 904 Set_First_Declarative_Item_Of 905 (Project_Declaration, To => Decl_Item); 906 Set_Current_Item_Node (Decl_Item, To => Naming); 907 Set_Name_Of (Naming, To => Name_Naming); 908 Set_Project_Of_Renamed_Package_Of 909 (Naming, To => Project_Naming_Node); 910 end; 911 912 -- Add an attribute declaration for Source_Dirs, initialized as an 913 -- empty list. Directories will be added as they are read from the 914 -- directory list file. 915 916 declare 917 Decl_Item : constant Project_Node_Id := 918 Default_Project_Node (Of_Kind => N_Declarative_Item); 919 920 Attribute : constant Project_Node_Id := 921 Default_Project_Node 922 (Of_Kind => N_Attribute_Declaration, 923 And_Expr_Kind => List); 924 925 Expression : constant Project_Node_Id := 926 Default_Project_Node 927 (Of_Kind => N_Expression, 928 And_Expr_Kind => List); 929 930 Term : constant Project_Node_Id := 931 Default_Project_Node 932 (Of_Kind => N_Term, And_Expr_Kind => List); 933 934 begin 935 Set_Next_Declarative_Item 936 (Decl_Item, 937 To => First_Declarative_Item_Of (Project_Declaration)); 938 Set_First_Declarative_Item_Of 939 (Project_Declaration, To => Decl_Item); 940 Set_Current_Item_Node (Decl_Item, To => Attribute); 941 Set_Name_Of (Attribute, To => Name_Source_Dirs); 942 Set_Expression_Of (Attribute, To => Expression); 943 Set_First_Term (Expression, To => Term); 944 Source_Dirs_List := 945 Default_Project_Node (Of_Kind => N_Literal_String_List, 946 And_Expr_Kind => List); 947 Set_Current_Term (Term, To => Source_Dirs_List); 948 end; 949 950 -- Add an attribute declaration for Source_List_File with the 951 -- source list file name that will be created. 952 953 declare 954 Decl_Item : constant Project_Node_Id := 955 Default_Project_Node (Of_Kind => N_Declarative_Item); 956 957 Attribute : constant Project_Node_Id := 958 Default_Project_Node 959 (Of_Kind => N_Attribute_Declaration, 960 And_Expr_Kind => Single); 961 962 Expression : constant Project_Node_Id := 963 Default_Project_Node 964 (Of_Kind => N_Expression, 965 And_Expr_Kind => Single); 966 967 Term : constant Project_Node_Id := 968 Default_Project_Node 969 (Of_Kind => N_Term, 970 And_Expr_Kind => Single); 971 972 Value : constant Project_Node_Id := 973 Default_Project_Node 974 (Of_Kind => N_Literal_String, 975 And_Expr_Kind => Single); 976 977 begin 978 Set_Next_Declarative_Item 979 (Decl_Item, 980 To => First_Declarative_Item_Of (Project_Declaration)); 981 Set_First_Declarative_Item_Of 982 (Project_Declaration, To => Decl_Item); 983 Set_Current_Item_Node (Decl_Item, To => Attribute); 984 Set_Name_Of (Attribute, To => Name_Source_List_File); 985 Set_Expression_Of (Attribute, To => Expression); 986 Set_First_Term (Expression, To => Term); 987 Set_Current_Term (Term, To => Value); 988 Name_Len := Source_List_Last; 989 Name_Buffer (1 .. Name_Len) := 990 Source_List_Path (1 .. Source_List_Last); 991 Set_String_Value_Of (Value, To => Name_Find); 992 end; 993 end if; 994 995 -- Process each directory 996 997 for Index in Directories'Range loop 998 999 declare 1000 Dir_Name : constant String := Directories (Index).all; 1001 Last : Natural := Dir_Name'Last; 1002 Recursively : Boolean := False; 1003 begin 1004 if Dir_Name'Length >= 4 1005 and then (Dir_Name (Last - 2 .. Last) = "/**") 1006 then 1007 Last := Last - 3; 1008 Recursively := True; 1009 end if; 1010 1011 if Project_File then 1012 1013 -- Add the directory in the list for attribute Source_Dirs 1014 1015 declare 1016 Expression : constant Project_Node_Id := 1017 Default_Project_Node 1018 (Of_Kind => N_Expression, 1019 And_Expr_Kind => Single); 1020 1021 Term : constant Project_Node_Id := 1022 Default_Project_Node 1023 (Of_Kind => N_Term, 1024 And_Expr_Kind => Single); 1025 1026 Value : constant Project_Node_Id := 1027 Default_Project_Node 1028 (Of_Kind => N_Literal_String, 1029 And_Expr_Kind => Single); 1030 1031 begin 1032 if Current_Source_Dir = Empty_Node then 1033 Set_First_Expression_In_List 1034 (Source_Dirs_List, To => Expression); 1035 else 1036 Set_Next_Expression_In_List 1037 (Current_Source_Dir, To => Expression); 1038 end if; 1039 1040 Current_Source_Dir := Expression; 1041 Set_First_Term (Expression, To => Term); 1042 Set_Current_Term (Term, To => Value); 1043 Name_Len := Dir_Name'Length; 1044 Name_Buffer (1 .. Name_Len) := Dir_Name; 1045 Set_String_Value_Of (Value, To => Name_Find); 1046 end; 1047 end if; 1048 1049 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); 1050 end; 1051 1052 end loop; 1053 1054 if Project_File then 1055 Close (Source_List_FD); 1056 end if; 1057 1058 declare 1059 Discard : Boolean; 1060 1061 begin 1062 -- Delete the file if it already exists 1063 1064 Delete_File 1065 (Path_Name (Directory_Last + 1 .. Path_Last), 1066 Success => Discard); 1067 1068 -- Create a new one 1069 1070 if Opt.Verbose_Mode then 1071 Output.Write_Str ("Creating new file """); 1072 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); 1073 Output.Write_Line (""""); 1074 end if; 1075 1076 Output_FD := Create_New_File 1077 (Path_Name (Directory_Last + 1 .. Path_Last), 1078 Fmode => Text); 1079 1080 -- Fails if project file cannot be created 1081 1082 if Output_FD = Invalid_FD then 1083 Prj.Com.Fail 1084 ("cannot create new """, Path_Name (1 .. Path_Last), """"); 1085 end if; 1086 1087 if Project_File then 1088 1089 -- Output the project file 1090 1091 Prj.PP.Pretty_Print 1092 (Project_Node, 1093 W_Char => Write_A_Char'Access, 1094 W_Eol => Write_Eol'Access, 1095 W_Str => Write_A_String'Access, 1096 Backward_Compatibility => False); 1097 Close (Output_FD); 1098 1099 -- Delete the naming project file if it already exists 1100 1101 Delete_File 1102 (Project_Naming_File_Name (1 .. Project_Naming_Last), 1103 Success => Discard); 1104 1105 -- Create a new one 1106 1107 if Opt.Verbose_Mode then 1108 Output.Write_Str ("Creating new naming project file """); 1109 Output.Write_Str (Project_Naming_File_Name 1110 (1 .. Project_Naming_Last)); 1111 Output.Write_Line (""""); 1112 end if; 1113 1114 Output_FD := Create_New_File 1115 (Project_Naming_File_Name (1 .. Project_Naming_Last), 1116 Fmode => Text); 1117 1118 -- Fails if naming project file cannot be created 1119 1120 if Output_FD = Invalid_FD then 1121 Prj.Com.Fail 1122 ("cannot create new """, 1123 Project_Naming_File_Name (1 .. Project_Naming_Last), 1124 """"); 1125 end if; 1126 1127 -- Output the naming project file 1128 1129 Prj.PP.Pretty_Print 1130 (Project_Naming_Node, 1131 W_Char => Write_A_Char'Access, 1132 W_Eol => Write_Eol'Access, 1133 W_Str => Write_A_String'Access, 1134 Backward_Compatibility => False); 1135 Close (Output_FD); 1136 1137 else 1138 -- Write to the output file each entry in the SFN_Pragmas table 1139 -- as an pragma Source_File_Name. 1140 1141 for Index in 1 .. SFN_Pragmas.Last loop 1142 Write_A_String ("pragma Source_File_Name"); 1143 Write_Eol; 1144 Write_A_String (" ("); 1145 Write_A_String (SFN_Pragmas.Table (Index).Unit.all); 1146 Write_A_String (","); 1147 Write_Eol; 1148 1149 if SFN_Pragmas.Table (Index).Spec then 1150 Write_A_String (" Spec_File_Name => """); 1151 1152 else 1153 Write_A_String (" Body_File_Name => """); 1154 end if; 1155 1156 Write_A_String (SFN_Pragmas.Table (Index).File.all); 1157 Write_A_String (""");"); 1158 Write_Eol; 1159 end loop; 1160 1161 Close (Output_FD); 1162 end if; 1163 end; 1164 1165 end Make; 1166 1167 ---------------- 1168 -- Write_Char -- 1169 ---------------- 1170 procedure Write_A_Char (C : Character) is 1171 begin 1172 Write_A_String ((1 => C)); 1173 end Write_A_Char; 1174 1175 --------------- 1176 -- Write_Eol -- 1177 --------------- 1178 1179 procedure Write_Eol is 1180 begin 1181 Write_A_String ((1 => ASCII.LF)); 1182 end Write_Eol; 1183 1184 -------------------- 1185 -- Write_A_String -- 1186 -------------------- 1187 1188 procedure Write_A_String (S : String) is 1189 Str : String (1 .. S'Length); 1190 1191 begin 1192 if S'Length > 0 then 1193 Str := S; 1194 1195 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then 1196 Prj.Com.Fail ("disk full"); 1197 end if; 1198 end if; 1199 end Write_A_String; 1200 1201end Prj.Makr; 1202