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