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-2019, 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'("ada"); 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 := Invalid_FD; 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 if Offset_FD /= Invalid_FD then 689 Close (Offset_FD); 690 end if; 691 692 Delete_File (Offset_Name'Address, Success); 693 return False; 694 end Parse_File; 695 696 ----------------------- 697 -- Parse_Offset_Info -- 698 ----------------------- 699 700 procedure Parse_Offset_Info 701 (Chop_File : File_Num; 702 Source : not null access String) 703 is 704 First_Unit : constant Unit_Num := Unit.Last + 1; 705 Bufferg : String_Access := null; 706 Parse_Ptr : File_Offset := Source'First; 707 Token_Ptr : File_Offset; 708 Info : Unit_Info; 709 710 function Match (Literal : String) return Boolean; 711 -- Checks if given string appears at the current Token_Ptr location 712 -- and if so, bumps Parse_Ptr past the token and returns True. If 713 -- the string is not present, sets Parse_Ptr to Token_Ptr and 714 -- returns False. 715 716 ----------- 717 -- Match -- 718 ----------- 719 720 function Match (Literal : String) return Boolean is 721 begin 722 Parse_Token (Source, Parse_Ptr, Token_Ptr); 723 724 if Source'Last + 1 - Token_Ptr < Literal'Length 725 or else 726 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal 727 then 728 Parse_Ptr := Token_Ptr; 729 return False; 730 end if; 731 732 Parse_Ptr := Token_Ptr + Literal'Length; 733 return True; 734 end Match; 735 736 -- Start of processing for Parse_Offset_Info 737 738 begin 739 loop 740 -- Set default values, should get changed for all 741 -- units/pragmas except for the last 742 743 Info.Chop_File := Chop_File; 744 Info.Length := 0; 745 746 -- Parse the current line of offset information into Info 747 -- and exit the loop if there are any errors or on EOF. 748 749 -- First case, parse a line in the following format: 750 751 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads 752 753 -- Note that the unit name can be an operator name in quotes. 754 -- This is of course illegal, but both GNAT and gnatchop handle 755 -- the case so that this error does not interfere with chopping. 756 757 -- The SR ir present indicates that a source reference pragma 758 -- was processed as part of this unit (and that therefore no 759 -- Source_Reference pragma should be generated. 760 761 if Match ("Unit") then 762 Parse_Token (Source, Parse_Ptr, Token_Ptr); 763 764 if Match ("(body)") then 765 Info.Kind := Unit_Body; 766 elsif Match ("(spec)") then 767 Info.Kind := Unit_Spec; 768 else 769 exit; 770 end if; 771 772 exit when not Match ("line"); 773 Parse_Token (Source, Parse_Ptr, Token_Ptr); 774 Info.Start_Line := Line_Num'Value 775 (Source (Token_Ptr .. Parse_Ptr - 1)); 776 777 exit when not Match ("file offset"); 778 Parse_Token (Source, Parse_Ptr, Token_Ptr); 779 Info.Offset := File_Offset'Value 780 (Source (Token_Ptr .. Parse_Ptr - 1)); 781 782 Info.SR_Present := Match ("SR, "); 783 784 exit when not Match ("file name"); 785 Parse_Token (Source, Parse_Ptr, Token_Ptr); 786 Info.File_Name := new String' 787 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1)); 788 Parse_EOL (Source, Parse_Ptr); 789 790 -- Second case, parse a line of the following form 791 792 -- Configuration pragmas at line 10, file offset 223 793 794 elsif Match ("Configuration pragmas at") then 795 Info.Kind := Config_Pragmas; 796 Info.File_Name := Config_File_Name; 797 798 exit when not Match ("line"); 799 Parse_Token (Source, Parse_Ptr, Token_Ptr); 800 Info.Start_Line := Line_Num'Value 801 (Source (Token_Ptr .. Parse_Ptr - 1)); 802 803 exit when not Match ("file offset"); 804 Parse_Token (Source, Parse_Ptr, Token_Ptr); 805 Info.Offset := File_Offset'Value 806 (Source (Token_Ptr .. Parse_Ptr - 1)); 807 808 Parse_EOL (Source, Parse_Ptr); 809 810 -- Third case, parse a line of the following form 811 812 -- Source_Reference pragma for file "filename" 813 814 -- This appears at the start of the file only, and indicates 815 -- the name to be used on any generated Source_Reference pragmas. 816 817 elsif Match ("Source_Reference pragma for file ") then 818 Parse_Token (Source, Parse_Ptr, Token_Ptr); 819 File.Table (Chop_File).SR_Name := 820 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2)); 821 Parse_EOL (Source, Parse_Ptr); 822 goto Continue; 823 824 -- Unrecognized keyword or end of file 825 826 else 827 exit; 828 end if; 829 830 -- Store the data in the Info record in the Unit.Table 831 832 Unit.Increment_Last; 833 Unit.Table (Unit.Last) := Info; 834 835 -- If this is not the first unit from the file, calculate 836 -- the length of the previous unit as difference of the offsets 837 838 if Unit.Last > First_Unit then 839 Unit.Table (Unit.Last - 1).Length := 840 Info.Offset - Unit.Table (Unit.Last - 1).Offset; 841 end if; 842 843 -- If not in compilation mode combine current unit with any 844 -- preceding configuration pragmas. 845 846 if not Compilation_Mode 847 and then Unit.Last > First_Unit 848 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas 849 then 850 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line; 851 Info.Offset := Unit.Table (Unit.Last - 1).Offset; 852 853 -- Delete the configuration pragma entry 854 855 Unit.Table (Unit.Last - 1) := Info; 856 Unit.Decrement_Last; 857 end if; 858 859 -- If in compilation mode, and previous entry is the initial 860 -- entry for the file and is for configuration pragmas, then 861 -- they are to be appended to every unit in the file. 862 863 if Compilation_Mode 864 and then Unit.Last = First_Unit + 1 865 and then Unit.Table (First_Unit).Kind = Config_Pragmas 866 then 867 Bufferg := 868 Get_Config_Pragmas 869 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit); 870 Unit.Table (Unit.Last - 1) := Info; 871 Unit.Decrement_Last; 872 end if; 873 874 Unit.Table (Unit.Last).Bufferg := Bufferg; 875 876 -- If in compilation mode, and this is not the first item, 877 -- combine configuration pragmas with previous unit, which 878 -- will cause an error message to be generated when the unit 879 -- is compiled. 880 881 if Compilation_Mode 882 and then Unit.Last > First_Unit 883 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 884 then 885 Unit.Decrement_Last; 886 end if; 887 888 <<Continue>> 889 null; 890 891 end loop; 892 893 -- Find out if the loop was exited prematurely because of 894 -- an error or if the EOF marker was found. 895 896 if Source (Parse_Ptr) /= EOF then 897 Error_Msg 898 (File.Table (Chop_File).Name.all & ": error parsing offset info"); 899 return; 900 end if; 901 902 -- Handle case of a chop file consisting only of config pragmas 903 904 if Unit.Last = First_Unit 905 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 906 then 907 -- In compilation mode, we append such a file to gnat.adc 908 909 if Compilation_Mode then 910 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit); 911 Unit.Decrement_Last; 912 913 -- In default (non-compilation) mode, this is invalid 914 915 else 916 Error_Msg 917 (File.Table (Chop_File).Name.all & 918 ": no units found (only pragmas)"); 919 Unit.Decrement_Last; 920 end if; 921 end if; 922 923 -- Handle case of a chop file ending with config pragmas. This can 924 -- happen only in default non-compilation mode, since in compilation 925 -- mode such configuration pragmas are part of the preceding unit. 926 -- We simply concatenate such pragmas to the previous file which 927 -- will cause a compilation error, which is appropriate. 928 929 if Unit.Last > First_Unit 930 and then Unit.Table (Unit.Last).Kind = Config_Pragmas 931 then 932 Unit.Decrement_Last; 933 end if; 934 end Parse_Offset_Info; 935 936 ----------------- 937 -- Parse_Token -- 938 ----------------- 939 940 procedure Parse_Token 941 (Source : not null access String; 942 Ptr : in out Positive; 943 Token_Ptr : out Positive) 944 is 945 In_Quotes : Boolean := False; 946 947 begin 948 -- Skip separators 949 950 while Source (Ptr) = ' ' or else Source (Ptr) = ',' loop 951 Ptr := Ptr + 1; 952 end loop; 953 954 Token_Ptr := Ptr; 955 956 -- Find end-of-token 957 958 while (In_Quotes 959 or else not (Source (Ptr) = ' ' or else Source (Ptr) = ',')) 960 and then Source (Ptr) >= ' ' 961 loop 962 if Source (Ptr) = '"' then 963 In_Quotes := not In_Quotes; 964 end if; 965 966 Ptr := Ptr + 1; 967 end loop; 968 end Parse_Token; 969 970 --------------- 971 -- Read_File -- 972 --------------- 973 974 procedure Read_File 975 (FD : File_Descriptor; 976 Contents : out String_Access; 977 Success : out Boolean) 978 is 979 Length : constant File_Offset := File_Offset (File_Length (FD)); 980 -- Include room for EOF char 981 Buffer : String_Access := new String (1 .. Length + 1); 982 983 This_Read : Integer; 984 Read_Ptr : File_Offset := 1; 985 986 begin 987 988 loop 989 This_Read := Read (FD, 990 A => Buffer (Read_Ptr)'Address, 991 N => Length + 1 - Read_Ptr); 992 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); 993 exit when This_Read <= 0; 994 end loop; 995 996 Buffer (Read_Ptr) := EOF; 997 998 -- Comment needed for the following ??? 999 -- Under what circumstances can the test fail ??? 1000 -- What is copy doing in that case??? 1001 1002 if Read_Ptr = Length then 1003 Contents := Buffer; 1004 1005 else 1006 Contents := new String (1 .. Read_Ptr); 1007 Contents.all := Buffer (1 .. Read_Ptr); 1008 Free (Buffer); 1009 end if; 1010 1011 Success := Read_Ptr = Length + 1; 1012 end Read_File; 1013 1014 ---------------------------- 1015 -- Report_Duplicate_Units -- 1016 ---------------------------- 1017 1018 function Report_Duplicate_Units return Boolean is 1019 US : SUnit_Num; 1020 U : Unit_Num; 1021 1022 Duplicates : Boolean := False; 1023 1024 begin 1025 US := 1; 1026 while US < SUnit_Num (Unit.Last) loop 1027 U := Sorted_Units.Table (US); 1028 1029 if Is_Duplicated (US) then 1030 Duplicates := True; 1031 1032 -- Move to last two versions of duplicated file to make it clearer 1033 -- to understand which file is retained in case of overwriting. 1034 1035 while US + 1 < SUnit_Num (Unit.Last) loop 1036 exit when not Is_Duplicated (US + 1); 1037 US := US + 1; 1038 end loop; 1039 1040 U := Sorted_Units.Table (US); 1041 1042 if Overwrite_Files then 1043 Warning_Msg (Unit.Table (U).File_Name.all 1044 & " is duplicated (all but last will be skipped)"); 1045 1046 elsif Unit.Table (U).Chop_File = 1047 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File 1048 then 1049 Error_Msg (Unit.Table (U).File_Name.all 1050 & " is duplicated in " 1051 & File.Table (Unit.Table (U).Chop_File).Name.all); 1052 1053 else 1054 Error_Msg (Unit.Table (U).File_Name.all 1055 & " in " 1056 & File.Table (Unit.Table (U).Chop_File).Name.all 1057 & " is duplicated in " 1058 & File.Table 1059 (Unit.Table 1060 (Sorted_Units.Table (US + 1)).Chop_File).Name.all); 1061 end if; 1062 end if; 1063 1064 US := US + 1; 1065 end loop; 1066 1067 if Duplicates and not Overwrite_Files then 1068 Put_Line ("use -w to overwrite files and keep last version"); 1069 end if; 1070 1071 return Duplicates; 1072 end Report_Duplicate_Units; 1073 1074 -------------------- 1075 -- Scan_Arguments -- 1076 -------------------- 1077 1078 function Scan_Arguments return Boolean is 1079 Kset : Boolean := False; 1080 -- Set true if -k switch found 1081 1082 begin 1083 Initialize_Option_Scan; 1084 1085 -- Scan options first 1086 1087 loop 1088 case Getopt ("c gnat? h k? p q r v w x -GCC=!") is 1089 when ASCII.NUL => 1090 exit; 1091 1092 when '-' => 1093 Gcc := new String'(Parameter); 1094 Gcc_Set := True; 1095 1096 when 'c' => 1097 Compilation_Mode := True; 1098 1099 when 'g' => 1100 Gnat_Args := 1101 new Argument_List'(Gnat_Args.all & 1102 new String'("-gnat" & Parameter)); 1103 1104 when 'h' => 1105 Usage; 1106 raise Types.Terminate_Program; 1107 1108 when 'k' => 1109 declare 1110 Param : String_Access := new String'(Parameter); 1111 1112 begin 1113 if Param.all /= "" then 1114 for J in Param'Range loop 1115 if Param (J) not in '0' .. '9' then 1116 Error_Msg ("-k# requires numeric parameter"); 1117 return False; 1118 end if; 1119 end loop; 1120 1121 else 1122 Param := new String'("8"); 1123 end if; 1124 1125 Gnat_Args := 1126 new Argument_List'(Gnat_Args.all & 1127 new String'("-gnatk" & Param.all)); 1128 Kset := True; 1129 end; 1130 1131 when 'p' => 1132 Preserve_Mode := True; 1133 1134 when 'q' => 1135 Quiet_Mode := True; 1136 1137 when 'r' => 1138 Source_References := True; 1139 1140 when 'v' => 1141 Verbose_Mode := True; 1142 Display_Version ("GNATCHOP", "1998"); 1143 1144 when 'w' => 1145 Overwrite_Files := True; 1146 1147 when 'x' => 1148 Exit_On_Error := True; 1149 1150 when others => 1151 null; 1152 end case; 1153 end loop; 1154 1155 if not Kset and then Maximum_File_Name_Length > 0 then 1156 1157 -- If this system has restricted filename lengths, tell gnat1 1158 -- about them, removing the leading blank from the image string. 1159 1160 Gnat_Args := 1161 new Argument_List'(Gnat_Args.all 1162 & new String'("-gnatk" 1163 & Maximum_File_Name_Length_String 1164 (Maximum_File_Name_Length_String'First + 1 1165 .. Maximum_File_Name_Length_String'Last))); 1166 end if; 1167 1168 -- Scan file names 1169 1170 loop 1171 declare 1172 S : constant String := Get_Argument (Do_Expansion => True); 1173 1174 begin 1175 exit when S = ""; 1176 File.Increment_Last; 1177 File.Table (File.Last).Name := new String'(S); 1178 File.Table (File.Last).SR_Name := null; 1179 end; 1180 end loop; 1181 1182 -- Case of more than one file where last file is a directory 1183 1184 if File.Last > 1 1185 and then Is_Directory (File.Table (File.Last).Name.all) 1186 then 1187 Directory := File.Table (File.Last).Name; 1188 File.Decrement_Last; 1189 1190 -- Make sure Directory is terminated with a directory separator, 1191 -- so we can generate the output by just appending a filename. 1192 1193 if Directory (Directory'Last) /= Directory_Separator 1194 and then Directory (Directory'Last) /= '/' 1195 then 1196 Directory := new String'(Directory.all & Directory_Separator); 1197 end if; 1198 1199 -- At least one filename must be given 1200 1201 elsif File.Last = 0 then 1202 if Argument_Count = 0 then 1203 Usage; 1204 else 1205 Try_Help; 1206 end if; 1207 1208 return False; 1209 1210 -- No directory given, set directory to null, so that we can just 1211 -- concatenate the directory name to the file name unconditionally. 1212 1213 else 1214 Directory := new String'(""); 1215 end if; 1216 1217 -- Finally check all filename arguments 1218 1219 for File_Num in 1 .. File.Last loop 1220 declare 1221 F : constant String := File.Table (File_Num).Name.all; 1222 1223 begin 1224 if Is_Directory (F) then 1225 Error_Msg (F & " is a directory, cannot be chopped"); 1226 return False; 1227 1228 elsif not Is_Regular_File (F) then 1229 Error_Msg (F & " not found"); 1230 return False; 1231 end if; 1232 end; 1233 end loop; 1234 1235 return True; 1236 1237 exception 1238 when Invalid_Switch => 1239 Error_Msg ("invalid switch " & Full_Switch); 1240 return False; 1241 1242 when Invalid_Parameter => 1243 Error_Msg ("-k switch requires numeric parameter"); 1244 return False; 1245 end Scan_Arguments; 1246 1247 ---------------- 1248 -- Sort_Units -- 1249 ---------------- 1250 1251 procedure Sort_Units is 1252 1253 procedure Move (From : Natural; To : Natural); 1254 -- Procedure used to sort the unit list 1255 -- Unit.Table (To) := Unit_List (From); used by sort 1256 1257 function Lt (Left, Right : Natural) return Boolean; 1258 -- Compares Left and Right units based on file name (first), 1259 -- Chop_File (second) and Offset (third). This ordering is 1260 -- important to keep the last version in case of duplicate files. 1261 1262 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt); 1263 -- Used for sorting on filename to detect duplicates 1264 1265 -------- 1266 -- Lt -- 1267 -------- 1268 1269 function Lt (Left, Right : Natural) return Boolean is 1270 L : Unit_Info renames 1271 Unit.Table (Sorted_Units.Table (SUnit_Num (Left))); 1272 1273 R : Unit_Info renames 1274 Unit.Table (Sorted_Units.Table (SUnit_Num (Right))); 1275 1276 begin 1277 return L.File_Name.all < R.File_Name.all 1278 or else (L.File_Name.all = R.File_Name.all 1279 and then (L.Chop_File < R.Chop_File 1280 or else (L.Chop_File = R.Chop_File 1281 and then L.Offset < R.Offset))); 1282 end Lt; 1283 1284 ---------- 1285 -- Move -- 1286 ---------- 1287 1288 procedure Move (From : Natural; To : Natural) is 1289 begin 1290 Sorted_Units.Table (SUnit_Num (To)) := 1291 Sorted_Units.Table (SUnit_Num (From)); 1292 end Move; 1293 1294 -- Start of processing for Sort_Units 1295 1296 begin 1297 Sorted_Units.Set_Last (SUnit_Num (Unit.Last)); 1298 1299 for J in 1 .. Unit.Last loop 1300 Sorted_Units.Table (SUnit_Num (J)) := J; 1301 end loop; 1302 1303 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch 1304 1305 Unit_Sort.Sort (Natural (Unit.Last)); 1306 1307 -- Set the Sorted_Index fields in the unit tables 1308 1309 for J in 1 .. SUnit_Num (Unit.Last) loop 1310 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J; 1311 end loop; 1312 end Sort_Units; 1313 1314 ----------- 1315 -- Usage -- 1316 ----------- 1317 1318 procedure Usage is 1319 begin 1320 Put_Line 1321 ("Usage: gnatchop [-c] [-h] [-k#] " & 1322 "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); 1323 1324 New_Line; 1325 1326 Display_Usage_Version_And_Help; 1327 1328 Put_Line 1329 (" -c compilation mode, configuration pragmas " & 1330 "follow RM rules"); 1331 1332 Put_Line 1333 (" -gnatxxx passes the -gnatxxx switch to gnat parser"); 1334 1335 Put_Line 1336 (" -h help: output this usage information"); 1337 1338 Put_Line 1339 (" -k# krunch file names of generated files to " & 1340 "no more than # characters"); 1341 1342 Put_Line 1343 (" -k krunch file names of generated files to " & 1344 "no more than 8 characters"); 1345 1346 Put_Line 1347 (" -p preserve time stamp, output files will " & 1348 "have same stamp as input"); 1349 1350 Put_Line 1351 (" -q quiet mode, no output of generated file " & 1352 "names"); 1353 1354 Put_Line 1355 (" -r generate Source_Reference pragmas refer" & 1356 "encing original source file"); 1357 1358 Put_Line 1359 (" -v verbose mode, output version and generat" & 1360 "ed commands"); 1361 1362 Put_Line 1363 (" -w overwrite existing filenames"); 1364 1365 Put_Line 1366 (" -x exit on error"); 1367 1368 Put_Line 1369 (" --GCC=xx specify the path of the gnat parser to be used"); 1370 1371 New_Line; 1372 Put_Line 1373 (" file... list of source files to be chopped"); 1374 1375 Put_Line 1376 (" dir directory location for split files (defa" & 1377 "ult = current directory)"); 1378 end Usage; 1379 1380 ----------------- 1381 -- Warning_Msg -- 1382 ----------------- 1383 1384 procedure Warning_Msg (Message : String) is 1385 begin 1386 Warning_Count := Warning_Count + 1; 1387 Put_Line (Standard_Error, "warning: " & Message); 1388 end Warning_Msg; 1389 1390 ------------------------- 1391 -- Write_Chopped_Files -- 1392 ------------------------- 1393 1394 function Write_Chopped_Files (Input : File_Num) return Boolean is 1395 Name : aliased constant String := 1396 File.Table (Input).Name.all & ASCII.NUL; 1397 FD : File_Descriptor; 1398 Buffer : String_Access; 1399 Success : Boolean; 1400 TS_Time : OS_Time; 1401 1402 BOM_Present : Boolean; 1403 BOM : BOM_Kind; 1404 -- Record presence of UTF8 BOM in input 1405 1406 begin 1407 FD := Open_Read (Name'Address, Binary); 1408 TS_Time := File_Time_Stamp (FD); 1409 1410 if FD = Invalid_FD then 1411 Error_Msg ("cannot open " & File.Table (Input).Name.all); 1412 return False; 1413 end if; 1414 1415 Read_File (FD, Buffer, Success); 1416 1417 if not Success then 1418 Error_Msg ("cannot read " & File.Table (Input).Name.all); 1419 Close (FD); 1420 return False; 1421 end if; 1422 1423 if not Quiet_Mode then 1424 Put_Line ("splitting " & File.Table (Input).Name.all & " into:"); 1425 end if; 1426 1427 -- Test for presence of BOM 1428 1429 Read_BOM (Buffer.all, BOM_Length, BOM, XML_Support => False); 1430 BOM_Present := BOM /= Unknown; 1431 1432 -- Only chop those units that come from this file 1433 1434 for Unit_Number in 1 .. Unit.Last loop 1435 if Unit.Table (Unit_Number).Chop_File = Input then 1436 Write_Unit 1437 (Source => Buffer, 1438 Num => Unit_Number, 1439 TS_Time => TS_Time, 1440 Write_BOM => BOM_Present and then Unit_Number /= 1, 1441 Success => Success); 1442 exit when not Success; 1443 end if; 1444 end loop; 1445 1446 Close (FD); 1447 return Success; 1448 end Write_Chopped_Files; 1449 1450 ----------------------- 1451 -- Write_Config_File -- 1452 ----------------------- 1453 1454 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is 1455 FD : File_Descriptor; 1456 Name : aliased constant String := "gnat.adc" & ASCII.NUL; 1457 Buffer : String_Access; 1458 Success : Boolean; 1459 Append : Boolean; 1460 Buffera : String_Access; 1461 Bufferl : Natural; 1462 1463 begin 1464 Write_gnat_adc := True; 1465 FD := Open_Read_Write (Name'Address, Binary); 1466 1467 if FD = Invalid_FD then 1468 FD := Create_File (Name'Address, Binary); 1469 Append := False; 1470 1471 if not Quiet_Mode then 1472 Put_Line ("writing configuration pragmas from " & 1473 File.Table (Input).Name.all & " to gnat.adc"); 1474 end if; 1475 1476 else 1477 Append := True; 1478 1479 if not Quiet_Mode then 1480 Put_Line 1481 ("appending configuration pragmas from " & 1482 File.Table (Input).Name.all & " to gnat.adc"); 1483 end if; 1484 end if; 1485 1486 Success := FD /= Invalid_FD; 1487 1488 if not Success then 1489 Error_Msg ("cannot create gnat.adc"); 1490 return; 1491 end if; 1492 1493 -- In append mode, acquire existing gnat.adc file 1494 1495 if Append then 1496 Read_File (FD, Buffera, Success); 1497 1498 if not Success then 1499 Error_Msg ("cannot read gnat.adc"); 1500 return; 1501 end if; 1502 1503 -- Find location of EOF byte if any to exclude from append 1504 1505 Bufferl := 1; 1506 while Bufferl <= Buffera'Last 1507 and then Buffera (Bufferl) /= EOF 1508 loop 1509 Bufferl := Bufferl + 1; 1510 end loop; 1511 1512 Bufferl := Bufferl - 1; 1513 Close (FD); 1514 1515 -- Write existing gnat.adc to new gnat.adc file 1516 1517 FD := Create_File (Name'Address, Binary); 1518 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl; 1519 1520 if not Success then 1521 Error_Msg ("error writing gnat.adc"); 1522 return; 1523 end if; 1524 end if; 1525 1526 Buffer := Get_Config_Pragmas (Input, U); 1527 1528 if Buffer /= null then 1529 Success := Write (FD, Buffer.all'Address, Buffer'Length) = 1530 Buffer'Length; 1531 1532 if not Success then 1533 Error_Msg ("disk full writing gnat.adc"); 1534 return; 1535 end if; 1536 end if; 1537 1538 Close (FD); 1539 end Write_Config_File; 1540 1541 ----------------------------------- 1542 -- Write_Source_Reference_Pragma -- 1543 ----------------------------------- 1544 1545 procedure Write_Source_Reference_Pragma 1546 (Info : Unit_Info; 1547 Line : Line_Num; 1548 File : Stream_IO.File_Type; 1549 EOL : EOL_String; 1550 Success : in out Boolean) 1551 is 1552 FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File); 1553 Nam : String_Access; 1554 1555 begin 1556 if Success and then Source_References and then not Info.SR_Present then 1557 if FTE.SR_Name /= null then 1558 Nam := FTE.SR_Name; 1559 else 1560 Nam := FTE.Name; 1561 end if; 1562 1563 declare 1564 Reference : String := 1565 "pragma Source_Reference (000000, """ 1566 & Nam.all & """);" & EOL.Str; 1567 1568 Pos : Positive := Reference'First; 1569 Lin : Line_Num := Line; 1570 1571 begin 1572 while Reference (Pos + 1) /= ',' loop 1573 Pos := Pos + 1; 1574 end loop; 1575 1576 while Reference (Pos) = '0' loop 1577 Reference (Pos) := Character'Val 1578 (Character'Pos ('0') + Lin mod 10); 1579 Lin := Lin / 10; 1580 Pos := Pos - 1; 1581 end loop; 1582 1583 -- Assume there are enough zeroes for any program length 1584 1585 pragma Assert (Lin = 0); 1586 1587 begin 1588 String'Write (Stream_IO.Stream (File), Reference); 1589 Success := True; 1590 exception 1591 when others => 1592 Success := False; 1593 end; 1594 end; 1595 end if; 1596 end Write_Source_Reference_Pragma; 1597 1598 ---------------- 1599 -- Write_Unit -- 1600 ---------------- 1601 1602 procedure Write_Unit 1603 (Source : not null access String; 1604 Num : Unit_Num; 1605 TS_Time : OS_Time; 1606 Write_BOM : Boolean; 1607 Success : out Boolean) 1608 is 1609 1610 procedure OS_Filename 1611 (Name : String; 1612 W_Name : Wide_String; 1613 OS_Name : Address; 1614 N_Length : access Natural; 1615 Encoding : Address; 1616 E_Length : access Natural); 1617 pragma Import (C, OS_Filename, "__gnat_os_filename"); 1618 -- Returns in OS_Name the proper name for the OS when used with the 1619 -- returned Encoding value. For example on Windows this will return the 1620 -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8 1621 -- (the form parameter for Stream_IO). 1622 -- 1623 -- Name is the filename and W_Name the same filename in Unicode 16 bits 1624 -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length 1625 -- are the length returned in OS_Name/Encoding respectively. 1626 1627 Info : Unit_Info renames Unit.Table (Num); 1628 Name : aliased constant String := Info.File_Name.all & ASCII.NUL; 1629 W_Name : aliased constant Wide_String := To_Wide_String (Name); 1630 EOL : constant EOL_String := 1631 Get_EOL (Source, Source'First + Info.Offset); 1632 OS_Name : aliased String (1 .. Name'Length * 2); 1633 O_Length : aliased Natural := OS_Name'Length; 1634 Encoding : aliased String (1 .. 64); 1635 E_Length : aliased Natural := Encoding'Length; 1636 Length : File_Offset; 1637 1638 begin 1639 -- Skip duplicated files 1640 1641 if Is_Duplicated (Info.Sorted_Index) then 1642 Put_Line (" " & Info.File_Name.all & " skipped"); 1643 Success := Overwrite_Files; 1644 return; 1645 end if; 1646 1647 -- Get OS filename 1648 1649 OS_Filename 1650 (Name, W_Name, 1651 OS_Name'Address, O_Length'Access, 1652 Encoding'Address, E_Length'Access); 1653 1654 declare 1655 E_Name : constant String := OS_Name (1 .. O_Length); 1656 OS_Encoding : constant String := Encoding (1 .. E_Length); 1657 File : Stream_IO.File_Type; 1658 1659 begin 1660 begin 1661 if not Overwrite_Files and then Exists (E_Name) then 1662 raise Stream_IO.Name_Error; 1663 else 1664 Stream_IO.Create 1665 (File, Stream_IO.Out_File, E_Name, OS_Encoding); 1666 Success := True; 1667 end if; 1668 1669 exception 1670 when Stream_IO.Name_Error | Stream_IO.Use_Error => 1671 Error_Msg ("cannot create " & Info.File_Name.all); 1672 return; 1673 end; 1674 1675 -- A length of 0 indicates that the rest of the file belongs to 1676 -- this unit. The actual length must be calculated now. Take into 1677 -- account that the last character (EOF) must not be written. 1678 1679 if Info.Length = 0 then 1680 Length := Source'Last - (Source'First + Info.Offset); 1681 else 1682 Length := Info.Length; 1683 end if; 1684 1685 -- Write BOM if required 1686 1687 if Write_BOM then 1688 String'Write 1689 (Stream_IO.Stream (File), 1690 Source.all (Source'First .. Source'First + BOM_Length - 1)); 1691 end if; 1692 1693 -- Prepend configuration pragmas if necessary 1694 1695 if Success and then Info.Bufferg /= null then 1696 Write_Source_Reference_Pragma (Info, 1, File, EOL, Success); 1697 String'Write (Stream_IO.Stream (File), Info.Bufferg.all); 1698 end if; 1699 1700 Write_Source_Reference_Pragma 1701 (Info, Info.Start_Line, File, EOL, Success); 1702 1703 if Success then 1704 begin 1705 String'Write 1706 (Stream_IO.Stream (File), 1707 Source (Source'First + Info.Offset .. 1708 Source'First + Info.Offset + Length - 1)); 1709 exception 1710 when Stream_IO.Use_Error | Stream_IO.Device_Error => 1711 Error_Msg ("disk full writing " & Info.File_Name.all); 1712 return; 1713 end; 1714 end if; 1715 1716 if not Quiet_Mode then 1717 Put_Line (" " & Info.File_Name.all); 1718 end if; 1719 1720 Stream_IO.Close (File); 1721 1722 if Preserve_Mode then 1723 Set_File_Last_Modify_Time_Stamp (E_Name, TS_Time); 1724 end if; 1725 end; 1726 end Write_Unit; 1727 1728 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); 1729 1730-- Start of processing for gnatchop 1731 1732begin 1733 -- Add the directory where gnatchop is invoked in front of the path, if 1734 -- gnatchop is invoked with directory information. 1735 1736 declare 1737 Command : constant String := Command_Name; 1738 1739 begin 1740 for Index in reverse Command'Range loop 1741 if Command (Index) = Directory_Separator then 1742 declare 1743 Absolute_Dir : constant String := 1744 Normalize_Pathname 1745 (Command (Command'First .. Index)); 1746 PATH : constant String := 1747 Absolute_Dir 1748 & Path_Separator 1749 & Getenv ("PATH").all; 1750 begin 1751 Setenv ("PATH", PATH); 1752 end; 1753 1754 exit; 1755 end if; 1756 end loop; 1757 end; 1758 1759 -- Process command line options and initialize global variables 1760 1761 -- First, scan to detect --version and/or --help 1762 1763 Check_Version_And_Help ("GNATCHOP", "1998"); 1764 1765 if not Scan_Arguments then 1766 Set_Exit_Status (Failure); 1767 return; 1768 end if; 1769 1770 -- Check presence of required executables 1771 1772 Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set); 1773 1774 if Gnat_Cmd = null then 1775 goto No_Files_Written; 1776 end if; 1777 1778 -- First parse all files and read offset information 1779 1780 for Num in 1 .. File.Last loop 1781 if not Parse_File (Num) then 1782 goto No_Files_Written; 1783 end if; 1784 end loop; 1785 1786 -- Check if any units have been found (assumes non-empty Unit.Table) 1787 1788 if Unit.Last = 0 then 1789 if not Write_gnat_adc then 1790 Error_Msg ("no compilation units found", Warning => True); 1791 end if; 1792 1793 goto No_Files_Written; 1794 end if; 1795 1796 Sort_Units; 1797 1798 -- Check if any duplicate files would be created. If so, emit a warning if 1799 -- Overwrite_Files is true, otherwise generate an error. 1800 1801 if Report_Duplicate_Units and then not Overwrite_Files then 1802 goto No_Files_Written; 1803 end if; 1804 1805 -- Check if any files exist, if so do not write anything Because all files 1806 -- have been parsed and checked already, there won't be any duplicates 1807 1808 if not Overwrite_Files and then Files_Exist then 1809 goto No_Files_Written; 1810 end if; 1811 1812 -- After this point, all source files are read in succession and chopped 1813 -- into their destination files. 1814 1815 -- Source_File_Name pragmas are handled as logical file 0 so write it first 1816 1817 for F in 1 .. File.Last loop 1818 if not Write_Chopped_Files (F) then 1819 Set_Exit_Status (Failure); 1820 return; 1821 end if; 1822 end loop; 1823 1824 if Warning_Count > 0 then 1825 declare 1826 Warnings_Msg : constant String := Warning_Count'Img & " warning(s)"; 1827 begin 1828 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True); 1829 end; 1830 end if; 1831 1832 return; 1833 1834<<No_Files_Written>> 1835 1836 -- Special error exit for all situations where no files have 1837 -- been written. 1838 1839 if not Write_gnat_adc then 1840 Error_Msg ("no source files written", Warning => True); 1841 end if; 1842 1843 return; 1844 1845exception 1846 when Types.Terminate_Program => 1847 null; 1848 1849end Gnatchop; 1850