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-2014, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Csets; 27with Makeutl; use Makeutl; 28with Opt; 29with Output; 30with Osint; use Osint; 31with Prj; use Prj; 32with Prj.Com; 33with Prj.Env; 34with Prj.Part; 35with Prj.PP; 36with Prj.Tree; use Prj.Tree; 37with Prj.Util; use Prj.Util; 38with Sdefault; 39with Snames; use Snames; 40with Stringt; 41with Table; use Table; 42with Tempdir; 43 44with Ada.Characters.Handling; use Ada.Characters.Handling; 45with GNAT.Directory_Operations; use GNAT.Directory_Operations; 46 47with System.Case_Util; use System.Case_Util; 48with System.CRTL; 49with System.HTable; 50 51package body Prj.Makr is 52 53 -- Packages of project files where unknown attributes are errors 54 55 -- All the following need comments ??? All global variables and 56 -- subprograms must be fully commented. 57 58 Very_Verbose : Boolean := False; 59 -- Set in call to Initialize to indicate very verbose output 60 61 Project_File : Boolean := False; 62 -- True when gnatname is creating/modifying a project file. False when 63 -- gnatname is creating a configuration pragmas file. 64 65 Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; 66 -- The project tree where the project file is parsed 67 68 Args : Argument_List_Access; 69 -- The list of arguments for calls to the compiler to get the unit names 70 -- and kinds (spec or body) in the Ada sources. 71 72 Path_Name : String_Access; 73 74 Path_Last : Natural; 75 76 Directory_Last : Natural := 0; 77 78 Output_Name : String_Access; 79 Output_Name_Last : Natural; 80 Output_Name_Id : Name_Id; 81 82 Project_Naming_File_Name : String_Access; 83 -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); 84 85 Project_Naming_Last : Natural; 86 Project_Naming_Id : Name_Id := No_Name; 87 88 Source_List_Path : String_Access; 89 -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); 90 Source_List_Last : Natural; 91 92 Source_List_FD : File_Descriptor; 93 94 Project_Node : Project_Node_Id := Empty_Node; 95 Project_Declaration : Project_Node_Id := Empty_Node; 96 Source_Dirs_List : Project_Node_Id := Empty_Node; 97 98 Project_Naming_Node : Project_Node_Id := Empty_Node; 99 Project_Naming_Decl : Project_Node_Id := Empty_Node; 100 Naming_Package : Project_Node_Id := Empty_Node; 101 Naming_Package_Comments : Project_Node_Id := Empty_Node; 102 103 Source_Files_Comments : Project_Node_Id := Empty_Node; 104 Source_Dirs_Comments : Project_Node_Id := Empty_Node; 105 Source_List_File_Comments : Project_Node_Id := Empty_Node; 106 107 Naming_String : aliased String := "naming"; 108 109 Gnatname_Packages : aliased String_List := (1 => Naming_String'Access); 110 111 Packages_To_Check_By_Gnatname : constant String_List_Access := 112 Gnatname_Packages'Access; 113 114 function Dup (Fd : File_Descriptor) return File_Descriptor; 115 116 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); 117 118 Gcc : constant String := "gcc"; 119 Gcc_Path : String_Access := null; 120 121 Non_Empty_Node : constant Project_Node_Id := 1; 122 -- Used for the With_Clause of the naming project 123 124 -- Turn off warnings for now around this redefinition of True and False, 125 -- but it really seems a bit horrible to do this redefinition ??? 126 127 pragma Warnings (Off); 128 type Matched_Type is (True, False, Excluded); 129 pragma Warnings (On); 130 131 Naming_File_Suffix : constant String := "_naming"; 132 Source_List_File_Suffix : constant String := "_source_list.txt"; 133 134 Output_FD : File_Descriptor; 135 -- To save the project file and its naming project file 136 137 procedure Write_Eol; 138 -- Output an empty line 139 140 procedure Write_A_Char (C : Character); 141 -- Write one character to Output_FD 142 143 procedure Write_A_String (S : String); 144 -- Write a String to Output_FD 145 146 package Processed_Directories is new Table.Table 147 (Table_Component_Type => String_Access, 148 Table_Index_Type => Natural, 149 Table_Low_Bound => 0, 150 Table_Initial => 10, 151 Table_Increment => 100, 152 Table_Name => "Prj.Makr.Processed_Directories"); 153 -- The list of already processed directories for each section, to avoid 154 -- processing several times the same directory in the same section. 155 156 package Source_Directories is new Table.Table 157 (Table_Component_Type => String_Access, 158 Table_Index_Type => Natural, 159 Table_Low_Bound => 0, 160 Table_Initial => 10, 161 Table_Increment => 100, 162 Table_Name => "Prj.Makr.Source_Directories"); 163 -- The complete list of directories to be put in attribute Source_Dirs in 164 -- the project file. 165 166 type Source is record 167 File_Name : Name_Id; 168 Unit_Name : Name_Id; 169 Index : Int := 0; 170 Spec : Boolean; 171 end record; 172 173 package Sources is new Table.Table 174 (Table_Component_Type => Source, 175 Table_Index_Type => Natural, 176 Table_Low_Bound => 0, 177 Table_Initial => 10, 178 Table_Increment => 100, 179 Table_Name => "Prj.Makr.Sources"); 180 -- The list of Ada sources found, with their unit name and kind, to be put 181 -- in the source attribute and package Naming of the project file, or in 182 -- the pragmas Source_File_Name in the configuration pragmas file. 183 184 package Source_Files is new System.HTable.Simple_HTable 185 (Header_Num => Prj.Header_Num, 186 Element => Boolean, 187 No_Element => False, 188 Key => Name_Id, 189 Hash => Prj.Hash, 190 Equal => "="); 191 -- Hash table to keep track of source file names, to avoid putting several 192 -- times the same file name in case of multi-unit files. 193 194 --------- 195 -- Dup -- 196 --------- 197 198 function Dup (Fd : File_Descriptor) return File_Descriptor is 199 begin 200 return File_Descriptor (System.CRTL.dup (Integer (Fd))); 201 end Dup; 202 203 ---------- 204 -- Dup2 -- 205 ---------- 206 207 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is 208 Fd : Integer; 209 pragma Warnings (Off, Fd); 210 begin 211 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); 212 end Dup2; 213 214 -------------- 215 -- Finalize -- 216 -------------- 217 218 procedure Finalize is 219 Discard : Boolean; 220 pragma Warnings (Off, Discard); 221 222 Current_Source_Dir : Project_Node_Id := Empty_Node; 223 224 begin 225 if Project_File then 226 -- If there were no already existing project file, or if the parsing 227 -- was unsuccessful, create an empty project node with the correct 228 -- name and its project declaration node. 229 230 if No (Project_Node) then 231 Project_Node := 232 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); 233 Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); 234 Set_Project_Declaration_Of 235 (Project_Node, Tree, 236 To => Default_Project_Node 237 (Of_Kind => N_Project_Declaration, In_Tree => Tree)); 238 239 end if; 240 241 end if; 242 243 -- Delete the file if it already exists 244 245 Delete_File 246 (Path_Name (Directory_Last + 1 .. Path_Last), 247 Success => Discard); 248 249 -- Create a new one 250 251 if Opt.Verbose_Mode then 252 Output.Write_Str ("Creating new file """); 253 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); 254 Output.Write_Line (""""); 255 end if; 256 257 Output_FD := Create_New_File 258 (Path_Name (Directory_Last + 1 .. Path_Last), 259 Fmode => Text); 260 261 -- Fails if project file cannot be created 262 263 if Output_FD = Invalid_FD then 264 Prj.Com.Fail 265 ("cannot create new """ & Path_Name (1 .. Path_Last) & """"); 266 end if; 267 268 if Project_File then 269 270 -- Delete the source list file, if it already exists 271 272 declare 273 Discard : Boolean; 274 pragma Warnings (Off, Discard); 275 begin 276 Delete_File 277 (Source_List_Path (1 .. Source_List_Last), 278 Success => Discard); 279 end; 280 281 -- And create a new source list file, fail if file cannot be created 282 283 Source_List_FD := Create_New_File 284 (Name => Source_List_Path (1 .. Source_List_Last), 285 Fmode => Text); 286 287 if Source_List_FD = Invalid_FD then 288 Prj.Com.Fail 289 ("cannot create file """ 290 & Source_List_Path (1 .. Source_List_Last) 291 & """"); 292 end if; 293 294 if Opt.Verbose_Mode then 295 Output.Write_Str ("Naming project file name is """); 296 Output.Write_Str 297 (Project_Naming_File_Name (1 .. Project_Naming_Last)); 298 Output.Write_Line (""""); 299 end if; 300 301 -- Create the naming project node 302 303 Project_Naming_Node := 304 Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); 305 Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); 306 Project_Naming_Decl := 307 Default_Project_Node 308 (Of_Kind => N_Project_Declaration, In_Tree => Tree); 309 Set_Project_Declaration_Of 310 (Project_Naming_Node, Tree, Project_Naming_Decl); 311 Naming_Package := 312 Default_Project_Node 313 (Of_Kind => N_Package_Declaration, In_Tree => Tree); 314 Set_Name_Of (Naming_Package, Tree, To => Name_Naming); 315 316 -- Add an attribute declaration for Source_Files as an empty list (to 317 -- indicate there are no sources in the naming project) and a package 318 -- Naming (that will be filled later). 319 320 declare 321 Decl_Item : constant Project_Node_Id := 322 Default_Project_Node 323 (Of_Kind => N_Declarative_Item, In_Tree => Tree); 324 325 Attribute : constant Project_Node_Id := 326 Default_Project_Node 327 (Of_Kind => N_Attribute_Declaration, 328 In_Tree => Tree, 329 And_Expr_Kind => List); 330 331 Expression : constant Project_Node_Id := 332 Default_Project_Node 333 (Of_Kind => N_Expression, 334 In_Tree => Tree, 335 And_Expr_Kind => List); 336 337 Term : constant Project_Node_Id := 338 Default_Project_Node 339 (Of_Kind => N_Term, 340 In_Tree => Tree, 341 And_Expr_Kind => List); 342 343 Empty_List : constant Project_Node_Id := 344 Default_Project_Node 345 (Of_Kind => N_Literal_String_List, 346 In_Tree => Tree); 347 348 begin 349 Set_First_Declarative_Item_Of 350 (Project_Naming_Decl, Tree, To => Decl_Item); 351 Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); 352 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); 353 Set_Name_Of (Attribute, Tree, To => Name_Source_Files); 354 Set_Expression_Of (Attribute, Tree, To => Expression); 355 Set_First_Term (Expression, Tree, To => Term); 356 Set_Current_Term (Term, Tree, To => Empty_List); 357 end; 358 359 -- Add a with clause on the naming project in the main project, if 360 -- there is not already one. 361 362 declare 363 With_Clause : Project_Node_Id := 364 First_With_Clause_Of (Project_Node, Tree); 365 366 begin 367 while Present (With_Clause) loop 368 exit when 369 Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; 370 With_Clause := Next_With_Clause_Of (With_Clause, Tree); 371 end loop; 372 373 if No (With_Clause) then 374 With_Clause := Default_Project_Node 375 (Of_Kind => N_With_Clause, In_Tree => Tree); 376 Set_Next_With_Clause_Of 377 (With_Clause, Tree, 378 To => First_With_Clause_Of (Project_Node, Tree)); 379 Set_First_With_Clause_Of 380 (Project_Node, Tree, To => With_Clause); 381 Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); 382 383 -- We set the project node to something different than 384 -- Empty_Node, so that Prj.PP does not generate a limited 385 -- with clause. 386 387 Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); 388 389 Name_Len := Project_Naming_Last; 390 Name_Buffer (1 .. Name_Len) := 391 Project_Naming_File_Name (1 .. Project_Naming_Last); 392 Set_String_Value_Of (With_Clause, Tree, To => Name_Find); 393 end if; 394 end; 395 396 Project_Declaration := Project_Declaration_Of (Project_Node, Tree); 397 398 -- Add a package Naming in the main project, that is a renaming of 399 -- package Naming in the naming project. 400 401 declare 402 Decl_Item : constant Project_Node_Id := 403 Default_Project_Node 404 (Of_Kind => N_Declarative_Item, 405 In_Tree => Tree); 406 407 Naming : constant Project_Node_Id := 408 Default_Project_Node 409 (Of_Kind => N_Package_Declaration, 410 In_Tree => Tree); 411 412 begin 413 Set_Next_Declarative_Item 414 (Decl_Item, Tree, 415 To => First_Declarative_Item_Of (Project_Declaration, Tree)); 416 Set_First_Declarative_Item_Of 417 (Project_Declaration, Tree, To => Decl_Item); 418 Set_Current_Item_Node (Decl_Item, Tree, To => Naming); 419 Set_Name_Of (Naming, Tree, To => Name_Naming); 420 Set_Project_Of_Renamed_Package_Of 421 (Naming, Tree, To => Project_Naming_Node); 422 423 -- Attach the comments, if any, that were saved for package 424 -- Naming. 425 426 Tree.Project_Nodes.Table (Naming).Comments := 427 Naming_Package_Comments; 428 end; 429 430 -- Add an attribute declaration for Source_Dirs, initialized as an 431 -- empty list. 432 433 declare 434 Decl_Item : constant Project_Node_Id := 435 Default_Project_Node 436 (Of_Kind => N_Declarative_Item, 437 In_Tree => Tree); 438 439 Attribute : constant Project_Node_Id := 440 Default_Project_Node 441 (Of_Kind => N_Attribute_Declaration, 442 In_Tree => Tree, 443 And_Expr_Kind => List); 444 445 Expression : constant Project_Node_Id := 446 Default_Project_Node 447 (Of_Kind => N_Expression, 448 In_Tree => Tree, 449 And_Expr_Kind => List); 450 451 Term : constant Project_Node_Id := 452 Default_Project_Node 453 (Of_Kind => N_Term, In_Tree => Tree, 454 And_Expr_Kind => List); 455 456 begin 457 Set_Next_Declarative_Item 458 (Decl_Item, Tree, 459 To => First_Declarative_Item_Of (Project_Declaration, Tree)); 460 Set_First_Declarative_Item_Of 461 (Project_Declaration, Tree, To => Decl_Item); 462 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); 463 Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); 464 Set_Expression_Of (Attribute, Tree, To => Expression); 465 Set_First_Term (Expression, Tree, To => Term); 466 Source_Dirs_List := 467 Default_Project_Node 468 (Of_Kind => N_Literal_String_List, 469 In_Tree => Tree, 470 And_Expr_Kind => List); 471 Set_Current_Term (Term, Tree, To => Source_Dirs_List); 472 473 -- Attach the comments, if any, that were saved for attribute 474 -- Source_Dirs. 475 476 Tree.Project_Nodes.Table (Attribute).Comments := 477 Source_Dirs_Comments; 478 end; 479 480 -- Put the source directories in attribute Source_Dirs 481 482 for Source_Dir_Index in 1 .. Source_Directories.Last loop 483 declare 484 Expression : constant Project_Node_Id := 485 Default_Project_Node 486 (Of_Kind => N_Expression, 487 In_Tree => Tree, 488 And_Expr_Kind => Single); 489 490 Term : constant Project_Node_Id := 491 Default_Project_Node 492 (Of_Kind => N_Term, 493 In_Tree => Tree, 494 And_Expr_Kind => Single); 495 496 Value : constant Project_Node_Id := 497 Default_Project_Node 498 (Of_Kind => N_Literal_String, 499 In_Tree => Tree, 500 And_Expr_Kind => Single); 501 502 begin 503 if No (Current_Source_Dir) then 504 Set_First_Expression_In_List 505 (Source_Dirs_List, Tree, To => Expression); 506 else 507 Set_Next_Expression_In_List 508 (Current_Source_Dir, Tree, To => Expression); 509 end if; 510 511 Current_Source_Dir := Expression; 512 Set_First_Term (Expression, Tree, To => Term); 513 Set_Current_Term (Term, Tree, To => Value); 514 Name_Len := 0; 515 Add_Str_To_Name_Buffer 516 (Source_Directories.Table (Source_Dir_Index).all); 517 Set_String_Value_Of (Value, Tree, To => Name_Find); 518 end; 519 end loop; 520 521 -- Add an attribute declaration for Source_Files or Source_List_File 522 -- with the source list file name that will be created. 523 524 declare 525 Decl_Item : constant Project_Node_Id := 526 Default_Project_Node 527 (Of_Kind => N_Declarative_Item, 528 In_Tree => Tree); 529 530 Attribute : constant Project_Node_Id := 531 Default_Project_Node 532 (Of_Kind => N_Attribute_Declaration, 533 In_Tree => Tree, 534 And_Expr_Kind => Single); 535 536 Expression : constant Project_Node_Id := 537 Default_Project_Node 538 (Of_Kind => N_Expression, 539 In_Tree => Tree, 540 And_Expr_Kind => Single); 541 542 Term : constant Project_Node_Id := 543 Default_Project_Node 544 (Of_Kind => N_Term, 545 In_Tree => Tree, 546 And_Expr_Kind => Single); 547 548 Value : constant Project_Node_Id := 549 Default_Project_Node 550 (Of_Kind => N_Literal_String, 551 In_Tree => Tree, 552 And_Expr_Kind => Single); 553 554 begin 555 Set_Next_Declarative_Item 556 (Decl_Item, Tree, 557 To => First_Declarative_Item_Of (Project_Declaration, Tree)); 558 Set_First_Declarative_Item_Of 559 (Project_Declaration, Tree, To => Decl_Item); 560 Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); 561 562 Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); 563 Set_Expression_Of (Attribute, Tree, To => Expression); 564 Set_First_Term (Expression, Tree, To => Term); 565 Set_Current_Term (Term, Tree, To => Value); 566 Name_Len := Source_List_Last; 567 Name_Buffer (1 .. Name_Len) := 568 Source_List_Path (1 .. Source_List_Last); 569 Set_String_Value_Of (Value, Tree, To => Name_Find); 570 571 -- If there was no comments for attribute Source_List_File, put 572 -- those for Source_Files, if they exist. 573 574 if Present (Source_List_File_Comments) then 575 Tree.Project_Nodes.Table (Attribute).Comments := 576 Source_List_File_Comments; 577 else 578 Tree.Project_Nodes.Table (Attribute).Comments := 579 Source_Files_Comments; 580 end if; 581 end; 582 583 -- Put the sources in the source list files and in the naming 584 -- project. 585 586 for Source_Index in 1 .. Sources.Last loop 587 588 -- Add the corresponding attribute in the 589 -- Naming package of the naming project. 590 591 declare 592 Current_Source : constant Source := 593 Sources.Table (Source_Index); 594 595 Decl_Item : constant Project_Node_Id := 596 Default_Project_Node 597 (Of_Kind => 598 N_Declarative_Item, 599 In_Tree => Tree); 600 601 Attribute : constant Project_Node_Id := 602 Default_Project_Node 603 (Of_Kind => 604 N_Attribute_Declaration, 605 In_Tree => Tree); 606 607 Expression : constant Project_Node_Id := 608 Default_Project_Node 609 (Of_Kind => N_Expression, 610 And_Expr_Kind => Single, 611 In_Tree => Tree); 612 613 Term : constant Project_Node_Id := 614 Default_Project_Node 615 (Of_Kind => N_Term, 616 And_Expr_Kind => Single, 617 In_Tree => Tree); 618 619 Value : constant Project_Node_Id := 620 Default_Project_Node 621 (Of_Kind => N_Literal_String, 622 And_Expr_Kind => Single, 623 In_Tree => Tree); 624 625 begin 626 -- Add source file name to the source list file if it is not 627 -- already there. 628 629 if not Source_Files.Get (Current_Source.File_Name) then 630 Source_Files.Set (Current_Source.File_Name, True); 631 Get_Name_String (Current_Source.File_Name); 632 Add_Char_To_Name_Buffer (ASCII.LF); 633 634 if Write (Source_List_FD, 635 Name_Buffer (1)'Address, 636 Name_Len) /= Name_Len 637 then 638 Prj.Com.Fail ("disk full"); 639 end if; 640 end if; 641 642 -- For an Ada source, add entry in package Naming 643 644 if Current_Source.Unit_Name /= No_Name then 645 Set_Next_Declarative_Item 646 (Decl_Item, 647 To => First_Declarative_Item_Of 648 (Naming_Package, Tree), 649 In_Tree => Tree); 650 Set_First_Declarative_Item_Of 651 (Naming_Package, 652 To => Decl_Item, 653 In_Tree => Tree); 654 Set_Current_Item_Node 655 (Decl_Item, 656 To => Attribute, 657 In_Tree => Tree); 658 659 -- Is it a spec or a body? 660 661 if Current_Source.Spec then 662 Set_Name_Of 663 (Attribute, Tree, 664 To => Name_Spec); 665 else 666 Set_Name_Of 667 (Attribute, Tree, 668 To => Name_Body); 669 end if; 670 671 -- Get the name of the unit 672 673 Get_Name_String (Current_Source.Unit_Name); 674 To_Lower (Name_Buffer (1 .. Name_Len)); 675 Set_Associative_Array_Index_Of 676 (Attribute, Tree, To => Name_Find); 677 678 Set_Expression_Of 679 (Attribute, Tree, To => Expression); 680 Set_First_Term 681 (Expression, Tree, To => Term); 682 Set_Current_Term 683 (Term, Tree, To => Value); 684 685 -- And set the name of the file 686 687 Set_String_Value_Of 688 (Value, Tree, To => Current_Source.File_Name); 689 Set_Source_Index_Of 690 (Value, Tree, To => Current_Source.Index); 691 end if; 692 end; 693 end loop; 694 695 -- Close the source list file 696 697 Close (Source_List_FD); 698 699 -- Output the project file 700 701 Prj.PP.Pretty_Print 702 (Project_Node, Tree, 703 W_Char => Write_A_Char'Access, 704 W_Eol => Write_Eol'Access, 705 W_Str => Write_A_String'Access, 706 Backward_Compatibility => False, 707 Max_Line_Length => 79); 708 Close (Output_FD); 709 710 -- Delete the naming project file if it already exists 711 712 Delete_File 713 (Project_Naming_File_Name (1 .. Project_Naming_Last), 714 Success => Discard); 715 716 -- Create a new one 717 718 if Opt.Verbose_Mode then 719 Output.Write_Str ("Creating new naming project file """); 720 Output.Write_Str (Project_Naming_File_Name 721 (1 .. Project_Naming_Last)); 722 Output.Write_Line (""""); 723 end if; 724 725 Output_FD := Create_New_File 726 (Project_Naming_File_Name (1 .. Project_Naming_Last), 727 Fmode => Text); 728 729 -- Fails if naming project file cannot be created 730 731 if Output_FD = Invalid_FD then 732 Prj.Com.Fail 733 ("cannot create new """ 734 & Project_Naming_File_Name (1 .. Project_Naming_Last) 735 & """"); 736 end if; 737 738 -- Output the naming project file 739 740 Prj.PP.Pretty_Print 741 (Project_Naming_Node, Tree, 742 W_Char => Write_A_Char'Access, 743 W_Eol => Write_Eol'Access, 744 W_Str => Write_A_String'Access, 745 Backward_Compatibility => False); 746 Close (Output_FD); 747 748 else 749 -- For each Ada source, write a pragma Source_File_Name to the 750 -- configuration pragmas file. 751 752 for Index in 1 .. Sources.Last loop 753 if Sources.Table (Index).Unit_Name /= No_Name then 754 Write_A_String ("pragma Source_File_Name"); 755 Write_Eol; 756 Write_A_String (" ("); 757 Write_A_String 758 (Get_Name_String (Sources.Table (Index).Unit_Name)); 759 Write_A_String (","); 760 Write_Eol; 761 762 if Sources.Table (Index).Spec then 763 Write_A_String (" Spec_File_Name => """); 764 765 else 766 Write_A_String (" Body_File_Name => """); 767 end if; 768 769 Write_A_String 770 (Get_Name_String (Sources.Table (Index).File_Name)); 771 772 Write_A_String (""""); 773 774 if Sources.Table (Index).Index /= 0 then 775 Write_A_String (", Index =>"); 776 Write_A_String (Sources.Table (Index).Index'Img); 777 end if; 778 779 Write_A_String (");"); 780 Write_Eol; 781 end if; 782 end loop; 783 784 Close (Output_FD); 785 end if; 786 end Finalize; 787 788 ---------------- 789 -- Initialize -- 790 ---------------- 791 792 procedure Initialize 793 (File_Path : String; 794 Project_File : Boolean; 795 Preproc_Switches : Argument_List; 796 Very_Verbose : Boolean; 797 Flags : Processing_Flags) 798 is 799 begin 800 Makr.Very_Verbose := Initialize.Very_Verbose; 801 Makr.Project_File := Initialize.Project_File; 802 803 -- Do some needed initializations 804 805 Csets.Initialize; 806 Snames.Initialize; 807 Stringt.Initialize; 808 809 Prj.Initialize (No_Project_Tree); 810 811 Prj.Tree.Initialize (Root_Environment, Flags); 812 Prj.Env.Initialize_Default_Project_Path 813 (Root_Environment.Project_Path, 814 Target_Name => Sdefault.Target_Name.all); 815 816 Prj.Tree.Initialize (Tree); 817 818 Sources.Set_Last (0); 819 Source_Directories.Set_Last (0); 820 821 -- Initialize the compiler switches 822 823 Args := new Argument_List (1 .. Preproc_Switches'Length + 6); 824 Args (1) := new String'("-c"); 825 Args (2) := new String'("-gnats"); 826 Args (3) := new String'("-gnatu"); 827 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches; 828 Args (4 + Preproc_Switches'Length) := new String'("-x"); 829 Args (5 + Preproc_Switches'Length) := new String'("ada"); 830 831 -- Get the path and file names 832 833 Path_Name := new 834 String (1 .. File_Path'Length + Project_File_Extension'Length); 835 Path_Last := File_Path'Length; 836 837 if File_Names_Case_Sensitive then 838 Path_Name (1 .. Path_Last) := File_Path; 839 else 840 Path_Name (1 .. Path_Last) := To_Lower (File_Path); 841 end if; 842 843 Path_Name (Path_Last + 1 .. Path_Name'Last) := 844 Project_File_Extension; 845 846 -- Get the end of directory information, if any 847 848 for Index in reverse 1 .. Path_Last loop 849 if Path_Name (Index) = Directory_Separator then 850 Directory_Last := Index; 851 exit; 852 end if; 853 end loop; 854 855 if Project_File then 856 if Path_Last < Project_File_Extension'Length + 1 857 or else Path_Name 858 (Path_Last - Project_File_Extension'Length + 1 .. Path_Last) 859 /= Project_File_Extension 860 then 861 Path_Last := Path_Name'Last; 862 end if; 863 864 Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last))); 865 Output_Name_Last := Output_Name'Last - 4; 866 867 -- If there is already a project file with the specified name, parse 868 -- it to get the components that are not automatically generated. 869 870 if Is_Regular_File (Output_Name (1 .. Path_Last)) then 871 if Opt.Verbose_Mode then 872 Output.Write_Str ("Parsing already existing project file """); 873 Output.Write_Str (Output_Name.all); 874 Output.Write_Line (""""); 875 end if; 876 877 Part.Parse 878 (In_Tree => Tree, 879 Project => Project_Node, 880 Project_File_Name => Output_Name.all, 881 Errout_Handling => Part.Finalize_If_Error, 882 Store_Comments => True, 883 Is_Config_File => False, 884 Env => Root_Environment, 885 Current_Directory => Get_Current_Dir, 886 Packages_To_Check => Packages_To_Check_By_Gnatname); 887 888 -- Fail if parsing was not successful 889 890 if No (Project_Node) then 891 Prj.Com.Fail ("parsing of existing project file failed"); 892 893 elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate then 894 Prj.Com.Fail ("aggregate projects are not supported"); 895 896 elsif Project_Qualifier_Of (Project_Node, Tree) = 897 Aggregate_Library 898 then 899 Prj.Com.Fail ("aggregate library projects are not supported"); 900 901 else 902 -- If parsing was successful, remove the components that are 903 -- automatically generated, if any, so that they will be 904 -- unconditionally added later. 905 906 -- Remove the with clause for the naming project file 907 908 declare 909 With_Clause : Project_Node_Id := 910 First_With_Clause_Of (Project_Node, Tree); 911 Previous : Project_Node_Id := Empty_Node; 912 913 begin 914 while Present (With_Clause) loop 915 if Prj.Tree.Name_Of (With_Clause, Tree) = 916 Project_Naming_Id 917 then 918 if No (Previous) then 919 Set_First_With_Clause_Of 920 (Project_Node, Tree, 921 To => Next_With_Clause_Of (With_Clause, Tree)); 922 else 923 Set_Next_With_Clause_Of 924 (Previous, Tree, 925 To => Next_With_Clause_Of (With_Clause, Tree)); 926 end if; 927 928 exit; 929 end if; 930 931 Previous := With_Clause; 932 With_Clause := Next_With_Clause_Of (With_Clause, Tree); 933 end loop; 934 end; 935 936 -- Remove attribute declarations of Source_Files, 937 -- Source_List_File, Source_Dirs, and the declaration of 938 -- package Naming, if they exist, but preserve the comments 939 -- attached to these nodes. 940 941 declare 942 Declaration : Project_Node_Id := 943 First_Declarative_Item_Of 944 (Project_Declaration_Of 945 (Project_Node, Tree), 946 Tree); 947 Previous : Project_Node_Id := Empty_Node; 948 Current_Node : Project_Node_Id := Empty_Node; 949 950 Name : Name_Id; 951 Kind_Of_Node : Project_Node_Kind; 952 Comments : Project_Node_Id; 953 954 begin 955 while Present (Declaration) loop 956 Current_Node := Current_Item_Node (Declaration, Tree); 957 958 Kind_Of_Node := Kind_Of (Current_Node, Tree); 959 960 if Kind_Of_Node = N_Attribute_Declaration or else 961 Kind_Of_Node = N_Package_Declaration 962 then 963 Name := Prj.Tree.Name_Of (Current_Node, Tree); 964 965 if Nam_In (Name, Name_Source_Files, 966 Name_Source_List_File, 967 Name_Source_Dirs, 968 Name_Naming) 969 then 970 Comments := 971 Tree.Project_Nodes.Table (Current_Node).Comments; 972 973 if Name = Name_Source_Files then 974 Source_Files_Comments := Comments; 975 976 elsif Name = Name_Source_List_File then 977 Source_List_File_Comments := Comments; 978 979 elsif Name = Name_Source_Dirs then 980 Source_Dirs_Comments := Comments; 981 982 elsif Name = Name_Naming then 983 Naming_Package_Comments := Comments; 984 end if; 985 986 if No (Previous) then 987 Set_First_Declarative_Item_Of 988 (Project_Declaration_Of (Project_Node, Tree), 989 Tree, 990 To => Next_Declarative_Item 991 (Declaration, Tree)); 992 993 else 994 Set_Next_Declarative_Item 995 (Previous, Tree, 996 To => Next_Declarative_Item 997 (Declaration, Tree)); 998 end if; 999 1000 else 1001 Previous := Declaration; 1002 end if; 1003 end if; 1004 1005 Declaration := Next_Declarative_Item (Declaration, Tree); 1006 end loop; 1007 end; 1008 end if; 1009 end if; 1010 1011 if Directory_Last /= 0 then 1012 Output_Name (1 .. Output_Name_Last - Directory_Last) := 1013 Output_Name (Directory_Last + 1 .. Output_Name_Last); 1014 Output_Name_Last := Output_Name_Last - Directory_Last; 1015 end if; 1016 1017 -- Get the project name id 1018 1019 Name_Len := Output_Name_Last; 1020 Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len); 1021 Output_Name_Id := Name_Find; 1022 1023 -- Create the project naming file name 1024 1025 Project_Naming_Last := Output_Name_Last; 1026 Project_Naming_File_Name := 1027 new String'(Output_Name (1 .. Output_Name_Last) & 1028 Naming_File_Suffix & 1029 Project_File_Extension); 1030 Project_Naming_Last := 1031 Project_Naming_Last + Naming_File_Suffix'Length; 1032 1033 -- Get the project naming id 1034 1035 Name_Len := Project_Naming_Last; 1036 Name_Buffer (1 .. Name_Len) := 1037 Project_Naming_File_Name (1 .. Name_Len); 1038 Project_Naming_Id := Name_Find; 1039 1040 Project_Naming_Last := 1041 Project_Naming_Last + Project_File_Extension'Length; 1042 1043 -- Create the source list file name 1044 1045 Source_List_Last := Output_Name_Last; 1046 Source_List_Path := 1047 new String'(Output_Name (1 .. Output_Name_Last) & 1048 Source_List_File_Suffix); 1049 Source_List_Last := 1050 Output_Name_Last + Source_List_File_Suffix'Length; 1051 1052 -- Add the project file extension to the project name 1053 1054 Output_Name 1055 (Output_Name_Last + 1 .. 1056 Output_Name_Last + Project_File_Extension'Length) := 1057 Project_File_Extension; 1058 Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; 1059 1060 -- Back up project file if it already exists 1061 1062 if not Opt.No_Backup 1063 and then Is_Regular_File (Path_Name (1 .. Path_Last)) 1064 then 1065 declare 1066 Discard : Boolean; 1067 Saved_Path : constant String := 1068 Path_Name (1 .. Path_Last) & ".saved_"; 1069 Nmb : Natural; 1070 1071 begin 1072 Nmb := 0; 1073 loop 1074 declare 1075 Img : constant String := Nmb'Img; 1076 1077 begin 1078 if not Is_Regular_File 1079 (Saved_Path & Img (2 .. Img'Last)) 1080 then 1081 Copy_File 1082 (Name => Path_Name (1 .. Path_Last), 1083 Pathname => Saved_Path & Img (2 .. Img'Last), 1084 Mode => Overwrite, 1085 Success => Discard); 1086 exit; 1087 end if; 1088 1089 Nmb := Nmb + 1; 1090 end; 1091 end loop; 1092 end; 1093 end if; 1094 end if; 1095 1096 -- Change the current directory to the directory of the project file, 1097 -- if any directory information is specified. 1098 1099 if Directory_Last /= 0 then 1100 begin 1101 Change_Dir (Path_Name (1 .. Directory_Last)); 1102 exception 1103 when Directory_Error => 1104 Prj.Com.Fail 1105 ("unknown directory """ 1106 & Path_Name (1 .. Directory_Last) 1107 & """"); 1108 end; 1109 end if; 1110 end Initialize; 1111 1112 ------------- 1113 -- Process -- 1114 ------------- 1115 1116 procedure Process 1117 (Directories : Argument_List; 1118 Name_Patterns : Regexp_List; 1119 Excluded_Patterns : Regexp_List; 1120 Foreign_Patterns : Regexp_List) 1121 is 1122 procedure Process_Directory (Dir_Name : String; Recursively : Boolean); 1123 -- Look for Ada and foreign sources in a directory, according to the 1124 -- patterns. When Recursively is True, after looking for sources in 1125 -- Dir_Name, look also in its subdirectories, if any. 1126 1127 ----------------------- 1128 -- Process_Directory -- 1129 ----------------------- 1130 1131 procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is 1132 Matched : Matched_Type := False; 1133 Str : String (1 .. 2_000); 1134 Canon : String (1 .. 2_000); 1135 Last : Natural; 1136 Dir : Dir_Type; 1137 Do_Process : Boolean := True; 1138 1139 Temp_File_Name : String_Access := null; 1140 Save_Last_Source_Index : Natural := 0; 1141 File_Name_Id : Name_Id := No_Name; 1142 1143 Current_Source : Source; 1144 1145 begin 1146 -- Avoid processing the same directory more than once 1147 1148 for Index in 1 .. Processed_Directories.Last loop 1149 if Processed_Directories.Table (Index).all = Dir_Name then 1150 Do_Process := False; 1151 exit; 1152 end if; 1153 end loop; 1154 1155 if Do_Process then 1156 if Opt.Verbose_Mode then 1157 Output.Write_Str ("Processing directory """); 1158 Output.Write_Str (Dir_Name); 1159 Output.Write_Line (""""); 1160 end if; 1161 1162 Processed_Directories. Increment_Last; 1163 Processed_Directories.Table (Processed_Directories.Last) := 1164 new String'(Dir_Name); 1165 1166 -- Get the source file names from the directory. Fails if the 1167 -- directory does not exist. 1168 1169 begin 1170 Open (Dir, Dir_Name); 1171 exception 1172 when Directory_Error => 1173 Prj.Com.Fail ("cannot open directory """ & Dir_Name & """"); 1174 end; 1175 1176 -- Process each regular file in the directory 1177 1178 File_Loop : loop 1179 Read (Dir, Str, Last); 1180 exit File_Loop when Last = 0; 1181 1182 -- Copy the file name and put it in canonical case to match 1183 -- against the patterns that have themselves already been put 1184 -- in canonical case. 1185 1186 Canon (1 .. Last) := Str (1 .. Last); 1187 Canonical_Case_File_Name (Canon (1 .. Last)); 1188 1189 if Is_Regular_File 1190 (Dir_Name & Directory_Separator & Str (1 .. Last)) 1191 then 1192 Matched := True; 1193 1194 Name_Len := Last; 1195 Name_Buffer (1 .. Name_Len) := Str (1 .. Last); 1196 File_Name_Id := Name_Find; 1197 1198 -- First, check if the file name matches at least one of 1199 -- the excluded expressions; 1200 1201 for Index in Excluded_Patterns'Range loop 1202 if 1203 Match (Canon (1 .. Last), Excluded_Patterns (Index)) 1204 then 1205 Matched := Excluded; 1206 exit; 1207 end if; 1208 end loop; 1209 1210 -- If it does not match any of the excluded expressions, 1211 -- check if the file name matches at least one of the 1212 -- regular expressions. 1213 1214 if Matched = True then 1215 Matched := False; 1216 1217 for Index in Name_Patterns'Range loop 1218 if 1219 Match 1220 (Canon (1 .. Last), Name_Patterns (Index)) 1221 then 1222 Matched := True; 1223 exit; 1224 end if; 1225 end loop; 1226 end if; 1227 1228 if Very_Verbose 1229 or else (Matched = True and then Opt.Verbose_Mode) 1230 then 1231 Output.Write_Str (" Checking """); 1232 Output.Write_Str (Str (1 .. Last)); 1233 Output.Write_Line (""": "); 1234 end if; 1235 1236 -- If the file name matches one of the regular expressions, 1237 -- parse it to get its unit name. 1238 1239 if Matched = True then 1240 declare 1241 FD : File_Descriptor; 1242 Success : Boolean; 1243 Saved_Output : File_Descriptor; 1244 Saved_Error : File_Descriptor; 1245 Tmp_File : Path_Name_Type; 1246 1247 begin 1248 -- If we don't have the path of the compiler yet, 1249 -- get it now. The compiler name may have a prefix, 1250 -- so we get the potentially prefixed name. 1251 1252 if Gcc_Path = null then 1253 declare 1254 Prefix_Gcc : String_Access := 1255 Program_Name (Gcc, "gnatname"); 1256 begin 1257 Gcc_Path := 1258 Locate_Exec_On_Path (Prefix_Gcc.all); 1259 Free (Prefix_Gcc); 1260 end; 1261 1262 if Gcc_Path = null then 1263 Prj.Com.Fail ("could not locate " & Gcc); 1264 end if; 1265 end if; 1266 1267 -- Create the temporary file 1268 1269 Tempdir.Create_Temp_File (FD, Tmp_File); 1270 1271 if FD = Invalid_FD then 1272 Prj.Com.Fail 1273 ("could not create temporary file"); 1274 1275 else 1276 Temp_File_Name := 1277 new String'(Get_Name_String (Tmp_File)); 1278 end if; 1279 1280 Args (Args'Last) := 1281 new String' 1282 (Dir_Name & Directory_Separator & Str (1 .. Last)); 1283 1284 -- Save the standard output and error 1285 1286 Saved_Output := Dup (Standout); 1287 Saved_Error := Dup (Standerr); 1288 1289 -- Set standard output and error to the temporary file 1290 1291 Dup2 (FD, Standout); 1292 Dup2 (FD, Standerr); 1293 1294 -- And spawn the compiler 1295 1296 Spawn (Gcc_Path.all, Args.all, Success); 1297 1298 -- Restore the standard output and error 1299 1300 Dup2 (Saved_Output, Standout); 1301 Dup2 (Saved_Error, Standerr); 1302 1303 -- Close the temporary file 1304 1305 Close (FD); 1306 1307 -- And close the saved standard output and error to 1308 -- avoid too many file descriptors. 1309 1310 Close (Saved_Output); 1311 Close (Saved_Error); 1312 1313 -- Now that standard output is restored, check if 1314 -- the compiler ran correctly. 1315 1316 -- Read the lines of the temporary file: 1317 -- they should contain the kind and name of the unit. 1318 1319 declare 1320 File : Text_File; 1321 Text_Line : String (1 .. 1_000); 1322 Text_Last : Natural; 1323 1324 begin 1325 Open (File, Temp_File_Name.all); 1326 1327 if not Is_Valid (File) then 1328 Prj.Com.Fail 1329 ("could not read temporary file " & 1330 Temp_File_Name.all); 1331 end if; 1332 1333 Save_Last_Source_Index := Sources.Last; 1334 1335 if End_Of_File (File) then 1336 if Opt.Verbose_Mode then 1337 if not Success then 1338 Output.Write_Str (" (process died) "); 1339 end if; 1340 end if; 1341 1342 else 1343 Line_Loop : while not End_Of_File (File) loop 1344 Get_Line (File, Text_Line, Text_Last); 1345 1346 -- Find the first closing parenthesis 1347 1348 Char_Loop : for J in 1 .. Text_Last loop 1349 if Text_Line (J) = ')' then 1350 if J >= 13 and then 1351 Text_Line (1 .. 4) = "Unit" 1352 then 1353 -- Add entry to Sources table 1354 1355 Name_Len := J - 12; 1356 Name_Buffer (1 .. Name_Len) := 1357 Text_Line (6 .. J - 7); 1358 Current_Source := 1359 (Unit_Name => Name_Find, 1360 File_Name => File_Name_Id, 1361 Index => 0, 1362 Spec => Text_Line (J - 5 .. J) = 1363 "(spec)"); 1364 1365 Sources.Append (Current_Source); 1366 end if; 1367 1368 exit Char_Loop; 1369 end if; 1370 end loop Char_Loop; 1371 end loop Line_Loop; 1372 end if; 1373 1374 if Save_Last_Source_Index = Sources.Last then 1375 if Opt.Verbose_Mode then 1376 Output.Write_Line (" not a unit"); 1377 end if; 1378 1379 else 1380 if Sources.Last > 1381 Save_Last_Source_Index + 1 1382 then 1383 for Index in Save_Last_Source_Index + 1 .. 1384 Sources.Last 1385 loop 1386 Sources.Table (Index).Index := 1387 Int (Index - Save_Last_Source_Index); 1388 end loop; 1389 end if; 1390 1391 for Index in Save_Last_Source_Index + 1 .. 1392 Sources.Last 1393 loop 1394 Current_Source := Sources.Table (Index); 1395 1396 if Opt.Verbose_Mode then 1397 if Current_Source.Spec then 1398 Output.Write_Str (" spec of "); 1399 1400 else 1401 Output.Write_Str (" body of "); 1402 end if; 1403 1404 Output.Write_Line 1405 (Get_Name_String 1406 (Current_Source.Unit_Name)); 1407 end if; 1408 end loop; 1409 end if; 1410 1411 Close (File); 1412 1413 Delete_File (Temp_File_Name.all, Success); 1414 end; 1415 end; 1416 1417 -- File name matches none of the regular expressions 1418 1419 else 1420 -- If file is not excluded, see if this is foreign source 1421 1422 if Matched /= Excluded then 1423 for Index in Foreign_Patterns'Range loop 1424 if Match (Canon (1 .. Last), 1425 Foreign_Patterns (Index)) 1426 then 1427 Matched := True; 1428 exit; 1429 end if; 1430 end loop; 1431 end if; 1432 1433 if Very_Verbose then 1434 case Matched is 1435 when False => 1436 Output.Write_Line ("no match"); 1437 1438 when Excluded => 1439 Output.Write_Line ("excluded"); 1440 1441 when True => 1442 Output.Write_Line ("foreign source"); 1443 end case; 1444 end if; 1445 1446 if Matched = True then 1447 1448 -- Add source file name without unit name 1449 1450 Name_Len := 0; 1451 Add_Str_To_Name_Buffer (Canon (1 .. Last)); 1452 Sources.Append 1453 ((File_Name => Name_Find, 1454 Unit_Name => No_Name, 1455 Index => 0, 1456 Spec => False)); 1457 end if; 1458 end if; 1459 end if; 1460 end loop File_Loop; 1461 1462 Close (Dir); 1463 end if; 1464 1465 -- If Recursively is True, call itself for each subdirectory. 1466 -- We do that, even when this directory has already been processed, 1467 -- because all of its subdirectories may not have been processed. 1468 1469 if Recursively then 1470 Open (Dir, Dir_Name); 1471 1472 loop 1473 Read (Dir, Str, Last); 1474 exit when Last = 0; 1475 1476 -- Do not call itself for "." or ".." 1477 1478 if Is_Directory 1479 (Dir_Name & Directory_Separator & Str (1 .. Last)) 1480 and then Str (1 .. Last) /= "." 1481 and then Str (1 .. Last) /= ".." 1482 then 1483 Process_Directory 1484 (Dir_Name & Directory_Separator & Str (1 .. Last), 1485 Recursively => True); 1486 end if; 1487 end loop; 1488 1489 Close (Dir); 1490 end if; 1491 end Process_Directory; 1492 1493 -- Start of processing for Process 1494 1495 begin 1496 Processed_Directories.Set_Last (0); 1497 1498 -- Process each directory 1499 1500 for Index in Directories'Range loop 1501 1502 declare 1503 Dir_Name : constant String := Directories (Index).all; 1504 Last : Natural := Dir_Name'Last; 1505 Recursively : Boolean := False; 1506 Found : Boolean; 1507 Canonical : String (1 .. Dir_Name'Length) := Dir_Name; 1508 1509 begin 1510 Canonical_Case_File_Name (Canonical); 1511 1512 Found := False; 1513 for J in 1 .. Source_Directories.Last loop 1514 if Source_Directories.Table (J).all = Canonical then 1515 Found := True; 1516 exit; 1517 end if; 1518 end loop; 1519 1520 if not Found then 1521 Source_Directories.Append (new String'(Canonical)); 1522 end if; 1523 1524 if Dir_Name'Length >= 4 1525 and then (Dir_Name (Last - 2 .. Last) = "/**") 1526 then 1527 Last := Last - 3; 1528 Recursively := True; 1529 end if; 1530 1531 Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); 1532 end; 1533 1534 end loop; 1535 end Process; 1536 1537 ---------------- 1538 -- Write_Char -- 1539 ---------------- 1540 procedure Write_A_Char (C : Character) is 1541 begin 1542 Write_A_String ((1 => C)); 1543 end Write_A_Char; 1544 1545 --------------- 1546 -- Write_Eol -- 1547 --------------- 1548 1549 procedure Write_Eol is 1550 begin 1551 Write_A_String ((1 => ASCII.LF)); 1552 end Write_Eol; 1553 1554 -------------------- 1555 -- Write_A_String -- 1556 -------------------- 1557 1558 procedure Write_A_String (S : String) is 1559 Str : String (1 .. S'Length); 1560 1561 begin 1562 if S'Length > 0 then 1563 Str := S; 1564 1565 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then 1566 Prj.Com.Fail ("disk full"); 1567 end if; 1568 end if; 1569 end Write_A_String; 1570 1571end Prj.Makr; 1572