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