1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T C H O P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-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 Ada.Characters.Conversions; use Ada.Characters.Conversions; 27with Ada.Command_Line; use Ada.Command_Line; 28with Ada.Directories; use Ada.Directories; 29with Ada.Streams.Stream_IO; use Ada.Streams; 30with Ada.Text_IO; use Ada.Text_IO; 31with System.CRTL; use System; use System.CRTL; 32 33with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; 34with GNAT.Command_Line; use GNAT.Command_Line; 35with GNAT.OS_Lib; use GNAT.OS_Lib; 36with GNAT.Heap_Sort_G; 37with GNAT.Table; 38 39with Switch; use Switch; 40with Types; 41 42procedure Gnatchop is 43 44 Config_File_Name : constant String_Access := new String'("gnat.adc"); 45 -- The name of the file holding the GNAT configuration pragmas 46 47 Gcc : String_Access := new String'("gcc"); 48 -- May be modified by switch --GCC= 49 50 Gcc_Set : Boolean := False; 51 -- True if a switch --GCC= is used 52 53 Gnat_Cmd : String_Access; 54 -- Command to execute the GNAT compiler 55 56 Gnat_Args : Argument_List_Access := 57 new Argument_List' 58 (new String'("-c"), 59 new String'("-x"), 60 new String'("ada"), 61 new String'("-gnats"), 62 new String'("-gnatu")); 63 -- Arguments used in Gnat_Cmd call 64 65 EOF : constant Character := Character'Val (26); 66 -- Special character to signal end of file. Not required in input files, 67 -- but properly treated if present. Not generated in output files except 68 -- as a result of copying input file. 69 70 BOM_Length : Natural := 0; 71 -- Reset to non-zero value if BOM detected at start of file 72 73 -------------------- 74 -- File arguments -- 75 -------------------- 76 77 subtype File_Num is Natural; 78 subtype File_Offset is Natural; 79 80 type File_Entry is record 81 Name : String_Access; 82 -- Name of chop file or directory 83 84 SR_Name : String_Access; 85 -- Null unless the chop file starts with a source reference pragma 86 -- in which case this field points to the file name from this pragma. 87 end record; 88 89 package File is new GNAT.Table 90 (Table_Component_Type => File_Entry, 91 Table_Index_Type => File_Num, 92 Table_Low_Bound => 1, 93 Table_Initial => 100, 94 Table_Increment => 100); 95 96 Directory : String_Access; 97 -- Record name of directory, or a null string if no directory given 98 99 Compilation_Mode : Boolean := False; 100 Overwrite_Files : Boolean := False; 101 Preserve_Mode : Boolean := False; 102 Quiet_Mode : Boolean := False; 103 Source_References : Boolean := False; 104 Verbose_Mode : Boolean := False; 105 Exit_On_Error : Boolean := False; 106 -- Global options 107 108 Write_gnat_adc : Boolean := False; 109 -- Gets set true if we append to gnat.adc or create a new gnat.adc. 110 -- Used to inhibit complaint about no units generated. 111 112 --------------- 113 -- Unit list -- 114 --------------- 115 116 type Line_Num is new Natural; 117 -- Line number (for source reference pragmas) 118 119 type Unit_Count_Type is new Integer; 120 subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last; 121 -- Used to refer to unit number in unit table 122 123 type SUnit_Num is new Integer; 124 -- Used to refer to entry in sorted units table. Note that entry 125 -- zero is only for use by Heapsort, and is not otherwise referenced. 126 127 type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas); 128 129 -- Structure to contain all necessary information for one unit. 130 -- Entries are also temporarily used to record config pragma sequences. 131 132 type Unit_Info is record 133 File_Name : String_Access; 134 -- File name from GNAT output line 135 136 Chop_File : File_Num; 137 -- File number in chop file sequence 138 139 Start_Line : Line_Num; 140 -- Line number from GNAT output line 141 142 Offset : File_Offset; 143 -- Offset name from GNAT output line 144 145 SR_Present : Boolean; 146 -- Set True if SR parameter present 147 148 Length : File_Offset; 149 -- A length of 0 means that the Unit is the last one in the file 150 151 Kind : Unit_Kind; 152 -- Indicates kind of unit 153 154 Sorted_Index : SUnit_Num; 155 -- Index of unit in sorted unit list 156 157 Bufferg : String_Access; 158 -- Pointer to buffer containing configuration pragmas to be prepended. 159 -- Null if no pragmas to be prepended. 160 end record; 161 162 -- The following table stores the unit offset information 163 164 package Unit is new GNAT.Table 165 (Table_Component_Type => Unit_Info, 166 Table_Index_Type => Unit_Count_Type, 167 Table_Low_Bound => 1, 168 Table_Initial => 500, 169 Table_Increment => 100); 170 171 -- The following table is used as a sorted index to the Unit.Table. 172 -- The entries in Unit.Table are not moved, instead we just shuffle 173 -- the entries in Sorted_Units. Note that the zeroeth entry in this 174 -- table is used by GNAT.Heap_Sort_G. 175 176 package Sorted_Units is new GNAT.Table 177 (Table_Component_Type => Unit_Num, 178 Table_Index_Type => SUnit_Num, 179 Table_Low_Bound => 0, 180 Table_Initial => 500, 181 Table_Increment => 100); 182 183 function Is_Duplicated (U : SUnit_Num) return Boolean; 184 -- Returns true if U is duplicated by a later unit. 185 -- Note that this function returns false for the last entry. 186 187 procedure Sort_Units; 188 -- Sort units and set up sorted unit table 189 190 ---------------------- 191 -- File_Descriptors -- 192 ---------------------- 193 194 function dup (handle : File_Descriptor) return File_Descriptor; 195 function dup2 (from, to : File_Descriptor) return File_Descriptor; 196 197 --------------------- 198 -- Local variables -- 199 --------------------- 200 201 Warning_Count : Natural := 0; 202 -- Count of warnings issued so far 203 204 ----------------------- 205 -- Local subprograms -- 206 ----------------------- 207 208 procedure Error_Msg (Message : String; Warning : Boolean := False); 209 -- Produce an error message on standard error output 210 211 function Files_Exist return Boolean; 212 -- Check Unit.Table for possible file names that already exist 213 -- in the file system. Returns true if files exist, False otherwise 214 215 function Get_Maximum_File_Name_Length return Integer; 216 pragma Import (C, Get_Maximum_File_Name_Length, 217 "__gnat_get_maximum_file_name_length"); 218 -- Function to get maximum file name length for system 219 220 Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length; 221 Maximum_File_Name_Length_String : constant String := 222 Integer'Image 223 (Maximum_File_Name_Length); 224 225 function Locate_Executable 226 (Program_Name : String; 227 Look_For_Prefix : Boolean := True) return String_Access; 228 -- Locate executable for given program name. This takes into account 229 -- the target-prefix of the current command, if Look_For_Prefix is True. 230 231 subtype EOL_Length is Natural range 0 .. 2; 232 -- Possible lengths of end of line sequence 233 234 type EOL_String (Len : EOL_Length := 0) is record 235 Str : String (1 .. Len); 236 end record; 237 238 function Get_EOL 239 (Source : not null access String; 240 Start : Positive) return EOL_String; 241 -- Return the line terminator used in the passed string 242 243 procedure Parse_EOL 244 (Source : not null access String; 245 Ptr : in out Positive); 246 -- On return Source (Ptr) is the first character of the next line 247 -- or EOF. Source.all must be terminated by EOF. 248 249 function Parse_File (Num : File_Num) return Boolean; 250 -- Calls the GNAT compiler to parse the given source file and parses the 251 -- output using Parse_Offset_Info. Returns True if parse operation 252 -- completes, False if some system error (e.g. failure to read the 253 -- offset information) occurs. 254 255 procedure Parse_Offset_Info 256 (Chop_File : File_Num; 257 Source : not null access String); 258 -- Parses the output of the compiler indicating the offsets and names of 259 -- the compilation units in Chop_File. 260 261 procedure Parse_Token 262 (Source : not null access String; 263 Ptr : in out Positive; 264 Token_Ptr : out Positive); 265 -- Skips any separators and stores the start of the token in Token_Ptr. 266 -- Then stores the position of the next separator in Ptr. On return 267 -- Source (Token_Ptr .. Ptr - 1) is the token. 268 269 procedure Read_File 270 (FD : File_Descriptor; 271 Contents : out String_Access; 272 Success : out Boolean); 273 -- Reads file associated with FS into the newly allocated string Contents. 274 -- Success is true iff the number of bytes read is equal to the file size. 275 276 function Report_Duplicate_Units return Boolean; 277 -- Output messages about duplicate units in the input files in Unit.Table 278 -- Returns True if any duplicates found, False if no duplicates found. 279 280 function Scan_Arguments return Boolean; 281 -- Scan command line options and set global variables accordingly. 282 -- Also scan out file and directory arguments. Returns True if scan 283 -- was successful, and False if the scan fails for any reason. 284 285 procedure Usage; 286 -- Output message on standard output describing syntax of gnatchop command 287 288 procedure Warning_Msg (Message : String); 289 -- Output a warning message on standard error and update warning count 290 291 function Write_Chopped_Files (Input : File_Num) return Boolean; 292 -- Write all units that result from chopping the Input file 293 294 procedure Write_Config_File (Input : File_Num; U : Unit_Num); 295 -- Call to write configuration pragmas (append them to gnat.adc). Input is 296 -- the file number for the chop file and U identifies the unit entry for 297 -- the configuration pragmas. 298 299 function Get_Config_Pragmas 300 (Input : File_Num; 301 U : Unit_Num) return String_Access; 302 -- Call to read configuration pragmas from given unit entry, and return a 303 -- buffer containing the pragmas to be appended to following units. Input 304 -- is the file number for the chop file and U identifies the unit entry for 305 -- the configuration pragmas. 306 307 procedure Write_Source_Reference_Pragma 308 (Info : Unit_Info; 309 Line : Line_Num; 310 File : Stream_IO.File_Type; 311 EOL : EOL_String; 312 Success : in out Boolean); 313 -- If Success is True on entry, writes a source reference pragma using 314 -- the chop file from Info, and the given line number. On return Success 315 -- indicates whether the write succeeded. If Success is False on entry, 316 -- or if the global flag Source_References is False, then the call to 317 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end 318 -- of line sequence to be written at the end of the pragma. 319 320 procedure Write_Unit 321 (Source : not null access String; 322 Num : Unit_Num; 323 TS_Time : OS_Time; 324 Write_BOM : Boolean; 325 Success : out Boolean); 326 -- Write one compilation unit of the source to file. Source is the pointer 327 -- to the input string, Num is the unit number, TS_Time is the timestamp, 328 -- Write_BOM is set True to write a UTF-8 BOM at the start of the file. 329 -- Success is set True unless the write attempt fails. 330 331 --------- 332 -- dup -- 333 --------- 334 335 function dup (handle : File_Descriptor) return File_Descriptor is 336 begin 337 return File_Descriptor (System.CRTL.dup (int (handle))); 338 end dup; 339 340 ---------- 341 -- dup2 -- 342 ---------- 343 344 function dup2 (from, to : File_Descriptor) return File_Descriptor is 345 begin 346 return File_Descriptor (System.CRTL.dup2 (int (from), int (to))); 347 end dup2; 348 349 --------------- 350 -- Error_Msg -- 351 --------------- 352 353 procedure Error_Msg (Message : String; Warning : Boolean := False) is 354 begin 355 Put_Line (Standard_Error, Message); 356 357 if not Warning then 358 Set_Exit_Status (Failure); 359 360 if Exit_On_Error then 361 raise Types.Terminate_Program; 362 end if; 363 end if; 364 end Error_Msg; 365 366 ----------------- 367 -- Files_Exist -- 368 ----------------- 369 370 function Files_Exist return Boolean is 371 Exists : Boolean := False; 372 373 begin 374 for SNum in 1 .. SUnit_Num (Unit.Last) loop 375 376 -- Only check and report for the last instance of duplicated files 377 378 if not Is_Duplicated (SNum) then 379 declare 380 Info : constant Unit_Info := 381 Unit.Table (Sorted_Units.Table (SNum)); 382 383 begin 384 if Is_Writable_File (Info.File_Name.all) then 385 Error_Msg (Info.File_Name.all 386 & " already exists, use -w to overwrite"); 387 Exists := True; 388 end if; 389 end; 390 end if; 391 end loop; 392 393 return Exists; 394 end Files_Exist; 395 396 ------------------------ 397 -- Get_Config_Pragmas -- 398 ------------------------ 399 400 function Get_Config_Pragmas 401 (Input : File_Num; 402 U : Unit_Num) return String_Access 403 is 404 Info : Unit_Info renames Unit.Table (U); 405 FD : File_Descriptor; 406 Name : aliased constant String := 407 File.Table (Input).Name.all & ASCII.NUL; 408 Length : File_Offset; 409 Buffer : String_Access; 410 Result : String_Access; 411 412 Success : Boolean; 413 pragma Warnings (Off, Success); 414 415 begin 416 FD := Open_Read (Name'Address, Binary); 417 418 if FD = Invalid_FD then 419 Error_Msg ("cannot open " & File.Table (Input).Name.all); 420 return null; 421 end if; 422 423 Read_File (FD, Buffer, Success); 424 425 -- A length of 0 indicates that the rest of the file belongs to 426 -- this unit. The actual length must be calculated now. Take into 427 -- account that the last character (EOF) must not be written. 428 429 if Info.Length = 0 then 430 Length := Buffer'Last - (Buffer'First + Info.Offset); 431 else 432 Length := Info.Length; 433 end if; 434 435 Result := new String'(Buffer (1 .. Length)); 436 Close (FD); 437 return Result; 438 end Get_Config_Pragmas; 439 440 ------------- 441 -- Get_EOL -- 442 ------------- 443 444 function Get_EOL 445 (Source : not null access String; 446 Start : Positive) return EOL_String 447 is 448 Ptr : Positive := Start; 449 First : Positive; 450 Last : Natural; 451 452 begin 453 -- Skip to end of line 454 455 while Source (Ptr) /= ASCII.CR and then 456 Source (Ptr) /= ASCII.LF and then 457 Source (Ptr) /= EOF 458 loop 459 Ptr := Ptr + 1; 460 end loop; 461 462 Last := Ptr; 463 464 if Source (Ptr) /= EOF then 465 466 -- Found CR or LF 467 468 First := Ptr; 469 470 else 471 First := Ptr + 1; 472 end if; 473 474 -- Recognize CR/LF 475 476 if Source (Ptr) = ASCII.CR and then Source (Ptr + 1) = ASCII.LF then 477 Last := First + 1; 478 end if; 479 480 return (Len => Last + 1 - First, Str => Source (First .. Last)); 481 end Get_EOL; 482 483 ------------------- 484 -- Is_Duplicated -- 485 ------------------- 486 487 function Is_Duplicated (U : SUnit_Num) return Boolean is 488 begin 489 return U < SUnit_Num (Unit.Last) 490 and then 491 Unit.Table (Sorted_Units.Table (U)).File_Name.all = 492 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all; 493 end Is_Duplicated; 494 495 ----------------------- 496 -- Locate_Executable -- 497 ----------------------- 498 499 function Locate_Executable 500 (Program_Name : String; 501 Look_For_Prefix : Boolean := True) return String_Access 502 is 503 Gnatchop_Str : constant String := "gnatchop"; 504 Current_Command : constant String := Normalize_Pathname (Command_Name); 505 End_Of_Prefix : Natural; 506 Start_Of_Prefix : Positive; 507 Start_Of_Suffix : Positive; 508 Result : String_Access; 509 510 begin 511 Start_Of_Prefix := Current_Command'First; 512 Start_Of_Suffix := Current_Command'Last + 1; 513 End_Of_Prefix := Start_Of_Prefix - 1; 514 515 if Look_For_Prefix then 516 517 -- Find Start_Of_Prefix 518 519 for J in reverse Current_Command'Range loop 520 if Current_Command (J) = '/' or else 521 Current_Command (J) = Directory_Separator or else 522 Current_Command (J) = ':' 523 then 524 Start_Of_Prefix := J + 1; 525 exit; 526 end if; 527 end loop; 528 529 -- Find End_Of_Prefix 530 531 for J in Start_Of_Prefix .. 532 Current_Command'Last - Gnatchop_Str'Length + 1 533 loop 534 if Current_Command (J .. J + Gnatchop_Str'Length - 1) = 535 Gnatchop_Str 536 then 537 End_Of_Prefix := J - 1; 538 exit; 539 end if; 540 end loop; 541 end if; 542 543 if End_Of_Prefix > Current_Command'First then 544 Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1; 545 end if; 546 547 declare 548 Command : constant String := 549 Current_Command (Start_Of_Prefix .. End_Of_Prefix) 550 & Program_Name 551 & Current_Command (Start_Of_Suffix .. 552 Current_Command'Last); 553 begin 554 Result := Locate_Exec_On_Path (Command); 555 556 if Result = null then 557 Error_Msg 558 (Command & ": installation problem, executable not found"); 559 end if; 560 end; 561 562 return Result; 563 end Locate_Executable; 564 565 --------------- 566 -- Parse_EOL -- 567 --------------- 568 569 procedure Parse_EOL 570 (Source : not null access String; 571 Ptr : in out Positive) is 572 begin 573 -- Skip to end of line 574 575 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF 576 and then Source (Ptr) /= EOF 577 loop 578 Ptr := Ptr + 1; 579 end loop; 580 581 if Source (Ptr) /= EOF then 582 Ptr := Ptr + 1; -- skip CR or LF 583 end if; 584 585 -- Skip past CR/LF or LF/CR combination 586 587 if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF) 588 and then Source (Ptr) /= Source (Ptr - 1) 589 then 590 Ptr := Ptr + 1; 591 end if; 592 end Parse_EOL; 593 594 ---------------- 595 -- Parse_File -- 596 ---------------- 597 598 function Parse_File (Num : File_Num) return Boolean is 599 Chop_Name : constant String_Access := File.Table (Num).Name; 600 Save_Stdout : constant File_Descriptor := dup (Standout); 601 Offset_Name : Temp_File_Name; 602 Offset_FD : File_Descriptor; 603 Buffer : String_Access; 604 Success : Boolean; 605 Failure : exception; 606 607 begin 608 -- Display copy of GNAT command if verbose mode 609 610 if Verbose_Mode then 611 Put (Gnat_Cmd.all); 612 613 for J in 1 .. Gnat_Args'Length loop 614 Put (' '); 615 Put (Gnat_Args (J).all); 616 end loop; 617 618 Put (' '); 619 Put_Line (Chop_Name.all); 620 end if; 621 622 -- Create temporary file 623 624 Create_Temp_File (Offset_FD, Offset_Name); 625 626 if Offset_FD = Invalid_FD then 627 Error_Msg ("gnatchop: cannot create temporary file"); 628 Close (Save_Stdout); 629 return False; 630 end if; 631 632 -- Redirect Stdout to this temporary file in the Unix way 633 634 if dup2 (Offset_FD, Standout) = Invalid_FD then 635 Error_Msg ("gnatchop: cannot redirect stdout to temporary file"); 636 Close (Save_Stdout); 637 Close (Offset_FD); 638 return False; 639 end if; 640 641 -- Call Gnat on the source filename argument with special options 642 -- to generate offset information. If this special compilation completes 643 -- successfully then we can do the actual gnatchop operation. 644 645 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success); 646 647 if not Success then 648 Error_Msg (Chop_Name.all & ": parse errors detected"); 649 Error_Msg (Chop_Name.all & ": chop may not be successful"); 650 end if; 651 652 -- Restore stdout 653 654 if dup2 (Save_Stdout, Standout) = Invalid_FD then 655 Error_Msg ("gnatchop: cannot restore stdout"); 656 end if; 657 658 -- Reopen the file to start reading from the beginning 659 660 Close (Offset_FD); 661 Close (Save_Stdout); 662 Offset_FD := Open_Read (Offset_Name'Address, Binary); 663 664 if Offset_FD = Invalid_FD then 665 Error_Msg ("gnatchop: cannot access offset info"); 666 raise Failure; 667 end if; 668 669 Read_File (Offset_FD, Buffer, Success); 670 671 if not Success then 672 Error_Msg ("gnatchop: error reading offset info"); 673 Close (Offset_FD); 674 raise Failure; 675 else 676 Parse_Offset_Info (Num, Buffer); 677 end if; 678 679 -- Close and delete temporary file 680 681 Close (Offset_FD); 682 Delete_File (Offset_Name'Address, Success); 683 684 return Success; 685 686 exception 687 when Failure | Types.Terminate_Program => 688 Close (Offset_FD); 689 Delete_File (Offset_Name'Address, Success); 690 return False; 691 692 end Parse_File; 693 694 ----------------------- 695 -- Parse_Offset_Info -- 696 ----------------------- 697 698 procedure Parse_Offset_Info 699 (Chop_File : File_Num; 700 Source : not null access String) 701 is 702 First_Unit : constant Unit_Num := Unit.Last + 1; 703 Bufferg : String_Access := null; 704 Parse_Ptr : File_Offset := Source'First; 705 Token_Ptr : File_Offset; 706 Info : Unit_Info; 707 708 function Match (Literal : String) return Boolean; 709 -- Checks if given string appears at the current Token_Ptr location 710 -- and if so, bumps Parse_Ptr past the token and returns True. If 711 -- the string is not present, sets Parse_Ptr to Token_Ptr and 712 -- returns False. 713 714 ----------- 715 -- Match -- 716 ----------- 717 718 function Match (Literal : String) return Boolean is 719 begin 720 Parse_Token (Source, Parse_Ptr, Token_Ptr); 721 722 if Source'Last + 1 - Token_Ptr < Literal'Length 723 or else 724 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal 725 then 726 Parse_Ptr := Token_Ptr; 727 return False; 728 end if; 729 730 Parse_Ptr := Token_Ptr + Literal'Length; 731 return True; 732 end Match; 733 734 -- Start of processing for Parse_Offset_Info 735 736 begin 737 loop 738 -- Set default values, should get changed for all 739 -- units/pragmas except for the last 740 741 Info.Chop_File := Chop_File; 742 Info.Length := 0; 743 744 -- Parse the current line of offset information into Info 745 -- and exit the loop if there are any errors or on EOF. 746 747 -- First case, parse a line in the following format: 748 749 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads 750 751 -- Note that the unit name can be an operator name in quotes. 752 -- This is of course illegal, but both GNAT and gnatchop handle 753 -- the case so that this error does not interfere with chopping. 754 755 -- The SR ir present indicates that a source reference pragma 756 -- was processed as part of this unit (and that therefore no 757 -- Source_Reference pragma should be generated. 758 759 if Match ("Unit") then 760 Parse_Token (Source, Parse_Ptr, Token_Ptr); 761 762 if Match ("(body)") then 763 Info.Kind := Unit_Body; 764 elsif Match ("(spec)") then 765 Info.Kind := Unit_Spec; 766 else 767 exit; 768 end if; 769 770 exit when not Match ("line"); 771 Parse_Token (Source, Parse_Ptr, Token_Ptr); 772 Info.Start_Line := Line_Num'Value 773 (Source (Token_Ptr .. Parse_Ptr - 1)); 774 775 exit when not Match ("file offset"); 776 Parse_Token (Source, Parse_Ptr, Token_Ptr); 777 Info.Offset := File_Offset'Value 778 (Source (Token_Ptr .. Parse_Ptr - 1)); 779 780 Info.SR_Present := Match ("SR, "); 781 782 exit when not Match ("file name"); 783 Parse_Token (Source, Parse_Ptr, Token_Ptr); 784 Info.File_Name := new String' 785 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1)); 786 Parse_EOL (Source, Parse_Ptr); 787 788 -- Second case, parse a line of the following form 789 790 -- Configuration pragmas at line 10, file offset 223 791 792 elsif Match ("Configuration pragmas at") then 793 Info.Kind := Config_Pragmas; 794 Info.File_Name := Config_File_Name; 795 796 exit when not Match ("line"); 797 Parse_Token (Source, Parse_Ptr, Token_Ptr); 798 Info.Start_Line := Line_Num'Value 799 (Source (Token_Ptr .. Parse_Ptr - 1)); 800 801 exit when not Match ("file offset"); 802 Parse_Token (Source, Parse_Ptr, Token_Ptr); 803 Info.Offset := File_Offset'Value 804 (Source (Token_Ptr .. Parse_Ptr - 1)); 805 806 Parse_EOL (Source, Parse_Ptr); 807 808 -- Third case, parse a line of the following form 809 810 -- Source_Reference pragma for file "filename" 811 812 -- This appears at the start of the file only, and indicates 813 -- the name to be used on any generated Source_Reference pragmas. 814 815 elsif Match ("Source_Reference pragma for file ") then 816 Parse_Token (Source, Parse_Ptr, Token_Ptr); 817 File.Table (Chop_File).SR_Name := 818 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2)); 819 Parse_EOL (Source, Parse_Ptr); 820 goto Continue; 821 822 -- Unrecognized keyword or end of file 823 824 else 825 exit; 826 end if; 827 828 -- Store the data in the Info record in the Unit.Table 829 830 Unit.Increment_Last; 831 Unit.Table (Unit.Last) := Info; 832 833 -- If this is not the first unit from the file, calculate 834 -- the length of the previous unit as difference of the offsets 835 836 if Unit.Last > First_Unit then 837 Unit.Table (Unit.Last - 1).Length := 838 Info.Offset - Unit.Table (Unit.Last - 1).Offset; 839 end if; 840 841 -- If not in compilation mode combine current unit with any 842 -- preceding configuration pragmas. 843 844 if not Compilation_Mode 845 and then Unit.Last > First_Unit 846 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas 847 then 848 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line; 849 Info.Offset := Unit.Table (Unit.Last - 1).Offset; 850 851 -- Delete the configuration pragma entry 852 853 Unit.Table (Unit.Last - 1) := Info; 854 Unit.Decrement_Last; 855 end if; 856 857 -- If in compilation mode, and previous entry is the initial 858 -- entry for the file and is for configuration pragmas, then 859 -- they are to be appended to every unit in the file. 860 861 if Compilation_Mode 862 and then Unit.Last = First_Unit + 1 863 and then Unit.Table (First_Unit).Kind = Config_Pragmas 864 then 865 Bufferg := 866 Get_Config_Pragmas 867 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit); 868 Unit.Table (Unit.Last - 1) := Info; 869 Unit.Decrement_Last; 870 end if; 871 872 Unit.Table (Unit.Last).Bufferg := Bufferg; 873 874 -- If in compilation mode, and this is not the first item, 875 -- combine configuration pragmas with previous unit, which 876 -- will cause an error message to be generated when the unit 877 -- is compiled. 878 879 if Compilation_Mode 880 and then Unit.Last > First_Unit 881 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 882 then 883 Unit.Decrement_Last; 884 end if; 885 886 <<Continue>> 887 null; 888 889 end loop; 890 891 -- Find out if the loop was exited prematurely because of 892 -- an error or if the EOF marker was found. 893 894 if Source (Parse_Ptr) /= EOF then 895 Error_Msg 896 (File.Table (Chop_File).Name.all & ": error parsing offset info"); 897 return; 898 end if; 899 900 -- Handle case of a chop file consisting only of config pragmas 901 902 if Unit.Last = First_Unit 903 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 904 then 905 -- In compilation mode, we append such a file to gnat.adc 906 907 if Compilation_Mode then 908 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit); 909 Unit.Decrement_Last; 910 911 -- In default (non-compilation) mode, this is invalid 912 913 else 914 Error_Msg 915 (File.Table (Chop_File).Name.all & 916 ": no units found (only pragmas)"); 917 Unit.Decrement_Last; 918 end if; 919 end if; 920 921 -- Handle case of a chop file ending with config pragmas. This can 922 -- happen only in default non-compilation mode, since in compilation 923 -- mode such configuration pragmas are part of the preceding unit. 924 -- We simply concatenate such pragmas to the previous file which 925 -- will cause a compilation error, which is appropriate. 926 927 if Unit.Last > First_Unit 928 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 929 then 930 Unit.Decrement_Last; 931 end if; 932 end Parse_Offset_Info; 933 934 ----------------- 935 -- Parse_Token -- 936 ----------------- 937 938 procedure Parse_Token 939 (Source : not null access String; 940 Ptr : in out Positive; 941 Token_Ptr : out Positive) 942 is 943 In_Quotes : Boolean := False; 944 945 begin 946 -- Skip separators 947 948 while Source (Ptr) = ' ' or else Source (Ptr) = ',' loop 949 Ptr := Ptr + 1; 950 end loop; 951 952 Token_Ptr := Ptr; 953 954 -- Find end-of-token 955 956 while (In_Quotes 957 or else not (Source (Ptr) = ' ' or else Source (Ptr) = ',')) 958 and then Source (Ptr) >= ' ' 959 loop 960 if Source (Ptr) = '"' then 961 In_Quotes := not In_Quotes; 962 end if; 963 964 Ptr := Ptr + 1; 965 end loop; 966 end Parse_Token; 967 968 --------------- 969 -- Read_File -- 970 --------------- 971 972 procedure Read_File 973 (FD : File_Descriptor; 974 Contents : out String_Access; 975 Success : out Boolean) 976 is 977 Length : constant File_Offset := File_Offset (File_Length (FD)); 978 -- Include room for EOF char 979 Buffer : String_Access := new String (1 .. Length + 1); 980 981 This_Read : Integer; 982 Read_Ptr : File_Offset := 1; 983 984 begin 985 986 loop 987 This_Read := Read (FD, 988 A => Buffer (Read_Ptr)'Address, 989 N => Length + 1 - Read_Ptr); 990 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); 991 exit when This_Read <= 0; 992 end loop; 993 994 Buffer (Read_Ptr) := EOF; 995 996 -- Comment needed for the following ??? 997 -- Under what circumstances can the test fail ??? 998 -- What is copy doing in that case??? 999 1000 if Read_Ptr = Length then 1001 Contents := Buffer; 1002 1003 else 1004 Contents := new String (1 .. Read_Ptr); 1005 Contents.all := Buffer (1 .. Read_Ptr); 1006 Free (Buffer); 1007 end if; 1008 1009 Success := Read_Ptr = Length + 1; 1010 end Read_File; 1011 1012 ---------------------------- 1013 -- Report_Duplicate_Units -- 1014 ---------------------------- 1015 1016 function Report_Duplicate_Units return Boolean is 1017 US : SUnit_Num; 1018 U : Unit_Num; 1019 1020 Duplicates : Boolean := False; 1021 1022 begin 1023 US := 1; 1024 while US < SUnit_Num (Unit.Last) loop 1025 U := Sorted_Units.Table (US); 1026 1027 if Is_Duplicated (US) then 1028 Duplicates := True; 1029 1030 -- Move to last two versions of duplicated file to make it clearer 1031 -- to understand which file is retained in case of overwriting. 1032 1033 while US + 1 < SUnit_Num (Unit.Last) loop 1034 exit when not Is_Duplicated (US + 1); 1035 US := US + 1; 1036 end loop; 1037 1038 U := Sorted_Units.Table (US); 1039 1040 if Overwrite_Files then 1041 Warning_Msg (Unit.Table (U).File_Name.all 1042 & " is duplicated (all but last will be skipped)"); 1043 1044 elsif Unit.Table (U).Chop_File = 1045 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File 1046 then 1047 Error_Msg (Unit.Table (U).File_Name.all 1048 & " is duplicated in " 1049 & File.Table (Unit.Table (U).Chop_File).Name.all); 1050 1051 else 1052 Error_Msg (Unit.Table (U).File_Name.all 1053 & " in " 1054 & File.Table (Unit.Table (U).Chop_File).Name.all 1055 & " is duplicated in " 1056 & File.Table 1057 (Unit.Table 1058 (Sorted_Units.Table (US + 1)).Chop_File).Name.all); 1059 end if; 1060 end if; 1061 1062 US := US + 1; 1063 end loop; 1064 1065 if Duplicates and not Overwrite_Files then 1066 Put_Line ("use -w to overwrite files and keep last version"); 1067 end if; 1068 1069 return Duplicates; 1070 end Report_Duplicate_Units; 1071 1072 -------------------- 1073 -- Scan_Arguments -- 1074 -------------------- 1075 1076 function Scan_Arguments return Boolean is 1077 Kset : Boolean := False; 1078 -- Set true if -k switch found 1079 1080 begin 1081 Initialize_Option_Scan; 1082 1083 -- Scan options first 1084 1085 loop 1086 case Getopt ("c gnat? h k? p q r v w x -GCC=!") is 1087 when ASCII.NUL => 1088 exit; 1089 1090 when '-' => 1091 Gcc := new String'(Parameter); 1092 Gcc_Set := True; 1093 1094 when 'c' => 1095 Compilation_Mode := True; 1096 1097 when 'g' => 1098 Gnat_Args := 1099 new Argument_List'(Gnat_Args.all & 1100 new String'("-gnat" & Parameter)); 1101 1102 when 'h' => 1103 Usage; 1104 raise Types.Terminate_Program; 1105 1106 when 'k' => 1107 declare 1108 Param : String_Access := new String'(Parameter); 1109 1110 begin 1111 if Param.all /= "" then 1112 for J in Param'Range loop 1113 if Param (J) not in '0' .. '9' then 1114 Error_Msg ("-k# requires numeric parameter"); 1115 return False; 1116 end if; 1117 end loop; 1118 1119 else 1120 Param := new String'("8"); 1121 end if; 1122 1123 Gnat_Args := 1124 new Argument_List'(Gnat_Args.all & 1125 new String'("-gnatk" & Param.all)); 1126 Kset := True; 1127 end; 1128 1129 when 'p' => 1130 Preserve_Mode := True; 1131 1132 when 'q' => 1133 Quiet_Mode := True; 1134 1135 when 'r' => 1136 Source_References := True; 1137 1138 when 'v' => 1139 Verbose_Mode := True; 1140 Display_Version ("GNATCHOP", "1998"); 1141 1142 when 'w' => 1143 Overwrite_Files := True; 1144 1145 when 'x' => 1146 Exit_On_Error := True; 1147 1148 when others => 1149 null; 1150 end case; 1151 end loop; 1152 1153 if not Kset and then Maximum_File_Name_Length > 0 then 1154 1155 -- If this system has restricted filename lengths, tell gnat1 1156 -- about them, removing the leading blank from the image string. 1157 1158 Gnat_Args := 1159 new Argument_List'(Gnat_Args.all 1160 & new String'("-gnatk" 1161 & Maximum_File_Name_Length_String 1162 (Maximum_File_Name_Length_String'First + 1 1163 .. Maximum_File_Name_Length_String'Last))); 1164 end if; 1165 1166 -- Scan file names 1167 1168 loop 1169 declare 1170 S : constant String := Get_Argument (Do_Expansion => True); 1171 1172 begin 1173 exit when S = ""; 1174 File.Increment_Last; 1175 File.Table (File.Last).Name := new String'(S); 1176 File.Table (File.Last).SR_Name := null; 1177 end; 1178 end loop; 1179 1180 -- Case of more than one file where last file is a directory 1181 1182 if File.Last > 1 1183 and then Is_Directory (File.Table (File.Last).Name.all) 1184 then 1185 Directory := File.Table (File.Last).Name; 1186 File.Decrement_Last; 1187 1188 -- Make sure Directory is terminated with a directory separator, 1189 -- so we can generate the output by just appending a filename. 1190 1191 if Directory (Directory'Last) /= Directory_Separator 1192 and then Directory (Directory'Last) /= '/' 1193 then 1194 Directory := new String'(Directory.all & Directory_Separator); 1195 end if; 1196 1197 -- At least one filename must be given 1198 1199 elsif File.Last = 0 then 1200 if Argument_Count = 0 then 1201 Usage; 1202 else 1203 Try_Help; 1204 end if; 1205 1206 return False; 1207 1208 -- No directory given, set directory to null, so that we can just 1209 -- concatenate the directory name to the file name unconditionally. 1210 1211 else 1212 Directory := new String'(""); 1213 end if; 1214 1215 -- Finally check all filename arguments 1216 1217 for File_Num in 1 .. File.Last loop 1218 declare 1219 F : constant String := File.Table (File_Num).Name.all; 1220 1221 begin 1222 if Is_Directory (F) then 1223 Error_Msg (F & " is a directory, cannot be chopped"); 1224 return False; 1225 1226 elsif not Is_Regular_File (F) then 1227 Error_Msg (F & " not found"); 1228 return False; 1229 end if; 1230 end; 1231 end loop; 1232 1233 return True; 1234 1235 exception 1236 when Invalid_Switch => 1237 Error_Msg ("invalid switch " & Full_Switch); 1238 return False; 1239 1240 when Invalid_Parameter => 1241 Error_Msg ("-k switch requires numeric parameter"); 1242 return False; 1243 end Scan_Arguments; 1244 1245 ---------------- 1246 -- Sort_Units -- 1247 ---------------- 1248 1249 procedure Sort_Units is 1250 1251 procedure Move (From : Natural; To : Natural); 1252 -- Procedure used to sort the unit list 1253 -- Unit.Table (To) := Unit_List (From); used by sort 1254 1255 function Lt (Left, Right : Natural) return Boolean; 1256 -- Compares Left and Right units based on file name (first), 1257 -- Chop_File (second) and Offset (third). This ordering is 1258 -- important to keep the last version in case of duplicate files. 1259 1260 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt); 1261 -- Used for sorting on filename to detect duplicates 1262 1263 -------- 1264 -- Lt -- 1265 -------- 1266 1267 function Lt (Left, Right : Natural) return Boolean is 1268 L : Unit_Info renames 1269 Unit.Table (Sorted_Units.Table (SUnit_Num (Left))); 1270 1271 R : Unit_Info renames 1272 Unit.Table (Sorted_Units.Table (SUnit_Num (Right))); 1273 1274 begin 1275 return L.File_Name.all < R.File_Name.all 1276 or else (L.File_Name.all = R.File_Name.all 1277 and then (L.Chop_File < R.Chop_File 1278 or else (L.Chop_File = R.Chop_File 1279 and then L.Offset < R.Offset))); 1280 end Lt; 1281 1282 ---------- 1283 -- Move -- 1284 ---------- 1285 1286 procedure Move (From : Natural; To : Natural) is 1287 begin 1288 Sorted_Units.Table (SUnit_Num (To)) := 1289 Sorted_Units.Table (SUnit_Num (From)); 1290 end Move; 1291 1292 -- Start of processing for Sort_Units 1293 1294 begin 1295 Sorted_Units.Set_Last (SUnit_Num (Unit.Last)); 1296 1297 for J in 1 .. Unit.Last loop 1298 Sorted_Units.Table (SUnit_Num (J)) := J; 1299 end loop; 1300 1301 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch 1302 1303 Unit_Sort.Sort (Natural (Unit.Last)); 1304 1305 -- Set the Sorted_Index fields in the unit tables 1306 1307 for J in 1 .. SUnit_Num (Unit.Last) loop 1308 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J; 1309 end loop; 1310 end Sort_Units; 1311 1312 ----------- 1313 -- Usage -- 1314 ----------- 1315 1316 procedure Usage is 1317 begin 1318 Put_Line 1319 ("Usage: gnatchop [-c] [-h] [-k#] " & 1320 "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); 1321 1322 New_Line; 1323 1324 Display_Usage_Version_And_Help; 1325 1326 Put_Line 1327 (" -c compilation mode, configuration pragmas " & 1328 "follow RM rules"); 1329 1330 Put_Line 1331 (" -gnatxxx passes the -gnatxxx switch to gnat parser"); 1332 1333 Put_Line 1334 (" -h help: output this usage information"); 1335 1336 Put_Line 1337 (" -k# krunch file names of generated files to " & 1338 "no more than # characters"); 1339 1340 Put_Line 1341 (" -k krunch file names of generated files to " & 1342 "no more than 8 characters"); 1343 1344 Put_Line 1345 (" -p preserve time stamp, output files will " & 1346 "have same stamp as input"); 1347 1348 Put_Line 1349 (" -q quiet mode, no output of generated file " & 1350 "names"); 1351 1352 Put_Line 1353 (" -r generate Source_Reference pragmas refer" & 1354 "encing original source file"); 1355 1356 Put_Line 1357 (" -v verbose mode, output version and generat" & 1358 "ed commands"); 1359 1360 Put_Line 1361 (" -w overwrite existing filenames"); 1362 1363 Put_Line 1364 (" -x exit on error"); 1365 1366 Put_Line 1367 (" --GCC=xx specify the path of the gnat parser to be used"); 1368 1369 New_Line; 1370 Put_Line 1371 (" file... list of source files to be chopped"); 1372 1373 Put_Line 1374 (" dir directory location for split files (defa" & 1375 "ult = current directory)"); 1376 end Usage; 1377 1378 ----------------- 1379 -- Warning_Msg -- 1380 ----------------- 1381 1382 procedure Warning_Msg (Message : String) is 1383 begin 1384 Warning_Count := Warning_Count + 1; 1385 Put_Line (Standard_Error, "warning: " & Message); 1386 end Warning_Msg; 1387 1388 ------------------------- 1389 -- Write_Chopped_Files -- 1390 ------------------------- 1391 1392 function Write_Chopped_Files (Input : File_Num) return Boolean is 1393 Name : aliased constant String := 1394 File.Table (Input).Name.all & ASCII.NUL; 1395 FD : File_Descriptor; 1396 Buffer : String_Access; 1397 Success : Boolean; 1398 TS_Time : OS_Time; 1399 1400 BOM_Present : Boolean; 1401 BOM : BOM_Kind; 1402 -- Record presence of UTF8 BOM in input 1403 1404 begin 1405 FD := Open_Read (Name'Address, Binary); 1406 TS_Time := File_Time_Stamp (FD); 1407 1408 if FD = Invalid_FD then 1409 Error_Msg ("cannot open " & File.Table (Input).Name.all); 1410 return False; 1411 end if; 1412 1413 Read_File (FD, Buffer, Success); 1414 1415 if not Success then 1416 Error_Msg ("cannot read " & File.Table (Input).Name.all); 1417 Close (FD); 1418 return False; 1419 end if; 1420 1421 if not Quiet_Mode then 1422 Put_Line ("splitting " & File.Table (Input).Name.all & " into:"); 1423 end if; 1424 1425 -- Test for presence of BOM 1426 1427 Read_BOM (Buffer.all, BOM_Length, BOM, False); 1428 BOM_Present := BOM /= Unknown; 1429 1430 -- Only chop those units that come from this file 1431 1432 for Unit_Number in 1 .. Unit.Last loop 1433 if Unit.Table (Unit_Number).Chop_File = Input then 1434 Write_Unit 1435 (Source => Buffer, 1436 Num => Unit_Number, 1437 TS_Time => TS_Time, 1438 Write_BOM => BOM_Present and then Unit_Number /= 1, 1439 Success => Success); 1440 exit when not Success; 1441 end if; 1442 end loop; 1443 1444 Close (FD); 1445 return Success; 1446 end Write_Chopped_Files; 1447 1448 ----------------------- 1449 -- Write_Config_File -- 1450 ----------------------- 1451 1452 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is 1453 FD : File_Descriptor; 1454 Name : aliased constant String := "gnat.adc" & ASCII.NUL; 1455 Buffer : String_Access; 1456 Success : Boolean; 1457 Append : Boolean; 1458 Buffera : String_Access; 1459 Bufferl : Natural; 1460 1461 begin 1462 Write_gnat_adc := True; 1463 FD := Open_Read_Write (Name'Address, Binary); 1464 1465 if FD = Invalid_FD then 1466 FD := Create_File (Name'Address, Binary); 1467 Append := False; 1468 1469 if not Quiet_Mode then 1470 Put_Line ("writing configuration pragmas from " & 1471 File.Table (Input).Name.all & " to gnat.adc"); 1472 end if; 1473 1474 else 1475 Append := True; 1476 1477 if not Quiet_Mode then 1478 Put_Line 1479 ("appending configuration pragmas from " & 1480 File.Table (Input).Name.all & " to gnat.adc"); 1481 end if; 1482 end if; 1483 1484 Success := FD /= Invalid_FD; 1485 1486 if not Success then 1487 Error_Msg ("cannot create gnat.adc"); 1488 return; 1489 end if; 1490 1491 -- In append mode, acquire existing gnat.adc file 1492 1493 if Append then 1494 Read_File (FD, Buffera, Success); 1495 1496 if not Success then 1497 Error_Msg ("cannot read gnat.adc"); 1498 return; 1499 end if; 1500 1501 -- Find location of EOF byte if any to exclude from append 1502 1503 Bufferl := 1; 1504 while Bufferl <= Buffera'Last 1505 and then Buffera (Bufferl) /= EOF 1506 loop 1507 Bufferl := Bufferl + 1; 1508 end loop; 1509 1510 Bufferl := Bufferl - 1; 1511 Close (FD); 1512 1513 -- Write existing gnat.adc to new gnat.adc file 1514 1515 FD := Create_File (Name'Address, Binary); 1516 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl; 1517 1518 if not Success then 1519 Error_Msg ("error writing gnat.adc"); 1520 return; 1521 end if; 1522 end if; 1523 1524 Buffer := Get_Config_Pragmas (Input, U); 1525 1526 if Buffer /= null then 1527 Success := Write (FD, Buffer.all'Address, Buffer'Length) = 1528 Buffer'Length; 1529 1530 if not Success then 1531 Error_Msg ("disk full writing gnat.adc"); 1532 return; 1533 end if; 1534 end if; 1535 1536 Close (FD); 1537 end Write_Config_File; 1538 1539 ----------------------------------- 1540 -- Write_Source_Reference_Pragma -- 1541 ----------------------------------- 1542 1543 procedure Write_Source_Reference_Pragma 1544 (Info : Unit_Info; 1545 Line : Line_Num; 1546 File : Stream_IO.File_Type; 1547 EOL : EOL_String; 1548 Success : in out Boolean) 1549 is 1550 FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File); 1551 Nam : String_Access; 1552 1553 begin 1554 if Success and then Source_References and then not Info.SR_Present then 1555 if FTE.SR_Name /= null then 1556 Nam := FTE.SR_Name; 1557 else 1558 Nam := FTE.Name; 1559 end if; 1560 1561 declare 1562 Reference : String := 1563 "pragma Source_Reference (000000, """ 1564 & Nam.all & """);" & EOL.Str; 1565 1566 Pos : Positive := Reference'First; 1567 Lin : Line_Num := Line; 1568 1569 begin 1570 while Reference (Pos + 1) /= ',' loop 1571 Pos := Pos + 1; 1572 end loop; 1573 1574 while Reference (Pos) = '0' loop 1575 Reference (Pos) := Character'Val 1576 (Character'Pos ('0') + Lin mod 10); 1577 Lin := Lin / 10; 1578 Pos := Pos - 1; 1579 end loop; 1580 1581 -- Assume there are enough zeroes for any program length 1582 1583 pragma Assert (Lin = 0); 1584 1585 begin 1586 String'Write (Stream_IO.Stream (File), Reference); 1587 Success := True; 1588 exception 1589 when others => 1590 Success := False; 1591 end; 1592 end; 1593 end if; 1594 end Write_Source_Reference_Pragma; 1595 1596 ---------------- 1597 -- Write_Unit -- 1598 ---------------- 1599 1600 procedure Write_Unit 1601 (Source : not null access String; 1602 Num : Unit_Num; 1603 TS_Time : OS_Time; 1604 Write_BOM : Boolean; 1605 Success : out Boolean) 1606 is 1607 1608 procedure OS_Filename 1609 (Name : String; 1610 W_Name : Wide_String; 1611 OS_Name : Address; 1612 N_Length : access Natural; 1613 Encoding : Address; 1614 E_Length : access Natural); 1615 pragma Import (C, OS_Filename, "__gnat_os_filename"); 1616 -- Returns in OS_Name the proper name for the OS when used with the 1617 -- returned Encoding value. For example on Windows this will return the 1618 -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 1619 -- (the form parameter for Stream_IO). 1620 -- 1621 -- Name is the filename and W_Name the same filename in Unicode 16 bits 1622 -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length 1623 -- are the length returned in OS_Name/Encoding respectively. 1624 1625 Info : Unit_Info renames Unit.Table (Num); 1626 Name : aliased constant String := Info.File_Name.all & ASCII.NUL; 1627 W_Name : aliased constant Wide_String := To_Wide_String (Name); 1628 EOL : constant EOL_String := 1629 Get_EOL (Source, Source'First + Info.Offset); 1630 OS_Name : aliased String (1 .. Name'Length * 2); 1631 O_Length : aliased Natural := OS_Name'Length; 1632 Encoding : aliased String (1 .. 64); 1633 E_Length : aliased Natural := Encoding'Length; 1634 Length : File_Offset; 1635 1636 begin 1637 -- Skip duplicated files 1638 1639 if Is_Duplicated (Info.Sorted_Index) then 1640 Put_Line (" " & Info.File_Name.all & " skipped"); 1641 Success := Overwrite_Files; 1642 return; 1643 end if; 1644 1645 -- Get OS filename 1646 1647 OS_Filename 1648 (Name, W_Name, 1649 OS_Name'Address, O_Length'Access, 1650 Encoding'Address, E_Length'Access); 1651 1652 declare 1653 E_Name : constant String := OS_Name (1 .. O_Length); 1654 OS_Encoding : constant String := Encoding (1 .. E_Length); 1655 File : Stream_IO.File_Type; 1656 1657 begin 1658 begin 1659 if not Overwrite_Files and then Exists (E_Name) then 1660 raise Stream_IO.Name_Error; 1661 else 1662 Stream_IO.Create 1663 (File, Stream_IO.Out_File, E_Name, OS_Encoding); 1664 Success := True; 1665 end if; 1666 1667 exception 1668 when Stream_IO.Name_Error | Stream_IO.Use_Error => 1669 Error_Msg ("cannot create " & Info.File_Name.all); 1670 return; 1671 end; 1672 1673 -- A length of 0 indicates that the rest of the file belongs to 1674 -- this unit. The actual length must be calculated now. Take into 1675 -- account that the last character (EOF) must not be written. 1676 1677 if Info.Length = 0 then 1678 Length := Source'Last - (Source'First + Info.Offset); 1679 else 1680 Length := Info.Length; 1681 end if; 1682 1683 -- Write BOM if required 1684 1685 if Write_BOM then 1686 String'Write 1687 (Stream_IO.Stream (File), 1688 Source.all (Source'First .. Source'First + BOM_Length - 1)); 1689 end if; 1690 1691 -- Prepend configuration pragmas if necessary 1692 1693 if Success and then Info.Bufferg /= null then 1694 Write_Source_Reference_Pragma (Info, 1, File, EOL, Success); 1695 String'Write (Stream_IO.Stream (File), Info.Bufferg.all); 1696 end if; 1697 1698 Write_Source_Reference_Pragma 1699 (Info, Info.Start_Line, File, EOL, Success); 1700 1701 if Success then 1702 begin 1703 String'Write 1704 (Stream_IO.Stream (File), 1705 Source (Source'First + Info.Offset .. 1706 Source'First + Info.Offset + Length - 1)); 1707 exception 1708 when Stream_IO.Use_Error | Stream_IO.Device_Error => 1709 Error_Msg ("disk full writing " & Info.File_Name.all); 1710 return; 1711 end; 1712 end if; 1713 1714 if not Quiet_Mode then 1715 Put_Line (" " & Info.File_Name.all); 1716 end if; 1717 1718 Stream_IO.Close (File); 1719 1720 if Preserve_Mode then 1721 Set_File_Last_Modify_Time_Stamp (E_Name, TS_Time); 1722 end if; 1723 end; 1724 end Write_Unit; 1725 1726 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); 1727 1728-- Start of processing for gnatchop 1729 1730begin 1731 -- Add the directory where gnatchop is invoked in front of the path, if 1732 -- gnatchop is invoked with directory information. 1733 1734 declare 1735 Command : constant String := Command_Name; 1736 1737 begin 1738 for Index in reverse Command'Range loop 1739 if Command (Index) = Directory_Separator then 1740 declare 1741 Absolute_Dir : constant String := 1742 Normalize_Pathname 1743 (Command (Command'First .. Index)); 1744 PATH : constant String := 1745 Absolute_Dir 1746 & Path_Separator 1747 & Getenv ("PATH").all; 1748 begin 1749 Setenv ("PATH", PATH); 1750 end; 1751 1752 exit; 1753 end if; 1754 end loop; 1755 end; 1756 1757 -- Process command line options and initialize global variables 1758 1759 -- First, scan to detect --version and/or --help 1760 1761 Check_Version_And_Help ("GNATCHOP", "1998"); 1762 1763 if not Scan_Arguments then 1764 Set_Exit_Status (Failure); 1765 return; 1766 end if; 1767 1768 -- Check presence of required executables 1769 1770 Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set); 1771 1772 if Gnat_Cmd = null then 1773 goto No_Files_Written; 1774 end if; 1775 1776 -- First parse all files and read offset information 1777 1778 for Num in 1 .. File.Last loop 1779 if not Parse_File (Num) then 1780 goto No_Files_Written; 1781 end if; 1782 end loop; 1783 1784 -- Check if any units have been found (assumes non-empty Unit.Table) 1785 1786 if Unit.Last = 0 then 1787 if not Write_gnat_adc then 1788 Error_Msg ("no compilation units found", Warning => True); 1789 end if; 1790 1791 goto No_Files_Written; 1792 end if; 1793 1794 Sort_Units; 1795 1796 -- Check if any duplicate files would be created. If so, emit a warning if 1797 -- Overwrite_Files is true, otherwise generate an error. 1798 1799 if Report_Duplicate_Units and then not Overwrite_Files then 1800 goto No_Files_Written; 1801 end if; 1802 1803 -- Check if any files exist, if so do not write anything Because all files 1804 -- have been parsed and checked already, there won't be any duplicates 1805 1806 if not Overwrite_Files and then Files_Exist then 1807 goto No_Files_Written; 1808 end if; 1809 1810 -- After this point, all source files are read in succession and chopped 1811 -- into their destination files. 1812 1813 -- Source_File_Name pragmas are handled as logical file 0 so write it first 1814 1815 for F in 1 .. File.Last loop 1816 if not Write_Chopped_Files (F) then 1817 Set_Exit_Status (Failure); 1818 return; 1819 end if; 1820 end loop; 1821 1822 if Warning_Count > 0 then 1823 declare 1824 Warnings_Msg : constant String := Warning_Count'Img & " warning(s)"; 1825 begin 1826 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True); 1827 end; 1828 end if; 1829 1830 return; 1831 1832<<No_Files_Written>> 1833 1834 -- Special error exit for all situations where no files have 1835 -- been written. 1836 1837 if not Write_gnat_adc then 1838 Error_Msg ("no source files written", Warning => True); 1839 end if; 1840 1841 return; 1842 1843exception 1844 when Types.Terminate_Program => 1845 null; 1846 1847end Gnatchop; 1848