1------------------------------------------------------------------------------ 2-- -- 3-- GPR PROJECT MANAGER -- 4-- -- 5-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 6-- -- 7-- This library is free software; you can redistribute it and/or modify it -- 8-- under terms of the GNU General Public License as published by the Free -- 9-- Software Foundation; either version 3, or (at your option) any later -- 10-- version. This library is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 13-- -- 14-- As a special exception under Section 7 of GPL version 3, you are granted -- 15-- additional permissions described in the GCC Runtime Library Exception, -- 16-- version 3.1, as published by the Free Software Foundation. -- 17-- -- 18-- You should have received a copy of the GNU General Public License and -- 19-- a copy of the GCC Runtime Library Exception along with this program; -- 20-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 21-- <http://www.gnu.org/licenses/>. -- 22-- -- 23------------------------------------------------------------------------------ 24 25with Ada.Unchecked_Deallocation; 26with Ada.Unchecked_Conversion; 27 28with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; 29 30with System; use System; 31 32pragma Warnings (Off); 33with System.WCh_Con; use System.WCh_Con; 34with System.WCh_Cnv; use System.WCh_Cnv; 35with System.Memory; 36pragma Warnings (On); 37 38with GPR.Err; 39with GPR.Erroutc; use GPR.Erroutc; 40with GPR.Names; use GPR.Names; 41with GPR.Opt; use GPR.Opt; 42with GPR.Output; use GPR.Output; 43 44package body GPR.Sinput is 45 46 Lines_Initial : constant := 500; 47 48 First : Boolean := True; 49 -- Flag used when Load_File is called the first time, to set 50 -- Main_Source_File. 51 -- The flag is reset to False at the first call to Load_Project_File. 52 -- Calling Reset_First sets it back to True. 53 54 procedure Free is new Ada.Unchecked_Deallocation 55 (Lines_Table_Type, Lines_Table_Ptr); 56 57 --------------------------- 58 -- Add_Line_Tables_Entry -- 59 --------------------------- 60 61 procedure Add_Line_Tables_Entry 62 (S : in out Source_File_Record; 63 P : Source_Ptr) 64 is 65 LL : Line_Number; 66 67 begin 68 -- Reallocate the lines tables if necessary 69 70 if S.Last_Source_Line = S.Lines_Table'Last then 71 declare 72 New_Table : constant Lines_Table_Ptr := 73 new Lines_Table_Type (1 .. S.Last_Source_Line * 2); 74 begin 75 New_Table (1 .. S.Last_Source_Line) := 76 S.Lines_Table (1 .. S.Last_Source_Line); 77 Free (S.Lines_Table); 78 S.Lines_Table := New_Table; 79 end; 80 end if; 81 82 S.Last_Source_Line := S.Last_Source_Line + 1; 83 LL := S.Last_Source_Line; 84 85 S.Lines_Table (LL) := P; 86 87 end Add_Line_Tables_Entry; 88 89 ------------------- 90 -- Check_For_BOM -- 91 ------------------- 92 93 procedure Check_For_BOM is 94 BOM : BOM_Kind; 95 Len : Natural; 96 Tst : String (1 .. 5); 97 C : Character; 98 99 begin 100 for J in 1 .. 5 loop 101 C := Source (Scan_Ptr + Source_Ptr (J) - 1); 102 103 -- Definitely no BOM if EOF character marks either end of file, or 104 -- an illegal non-BOM character if not at the end of file. 105 106 if C = EOF then 107 return; 108 end if; 109 110 Tst (J) := C; 111 end loop; 112 113 Read_BOM (Tst, Len, BOM, False); 114 115 case BOM is 116 when UTF8_All => 117 Scan_Ptr := Scan_Ptr + Source_Ptr (Len); 118 Wide_Character_Encoding_Method := WCEM_UTF8; 119 Upper_Half_Encoding := True; 120 121 when UTF16_LE | UTF16_BE => 122 Set_Standard_Error; 123 Write_Line ("UTF-16 encoding format not recognized"); 124 raise Unrecoverable_Error; 125 126 when UTF32_LE | UTF32_BE => 127 Set_Standard_Error; 128 Write_Line ("UTF-32 encoding format not recognized"); 129 raise Unrecoverable_Error; 130 131 when Unknown => 132 null; 133 134 when others => 135 raise Program_Error; 136 end case; 137 end Check_For_BOM; 138 139 ----------------------------- 140 -- Clear_Source_File_Table -- 141 ----------------------------- 142 143 procedure Clear_Source_File_Table is 144 begin 145 for X in 1 .. Source_File.Last loop 146 declare 147 S : Source_File_Record renames Source_File.Table (X); 148 Lo : constant Source_Ptr := S.Source_First; 149 Hi : constant Source_Ptr := S.Source_Last; 150 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); 151 -- Physical buffer allocated 152 153 type Actual_Source_Ptr is access Actual_Source_Buffer; 154 -- This is the pointer type for the physical buffer allocated 155 156 procedure Free is new Ada.Unchecked_Deallocation 157 (Actual_Source_Buffer, Actual_Source_Ptr); 158 159 pragma Suppress (All_Checks); 160 161 pragma Warnings (Off); 162 -- The following unchecked conversion is aliased safe, since it 163 -- is not used to create improperly aliased pointer values. 164 165 function To_Actual_Source_Ptr is new 166 Ada.Unchecked_Conversion (Address, Actual_Source_Ptr); 167 168 pragma Warnings (On); 169 170 Actual_Ptr : Actual_Source_Ptr := 171 To_Actual_Source_Ptr (S.Source_Text (Lo)'Address); 172 173 begin 174 Free (Actual_Ptr); 175 Free (S.Lines_Table); 176 end; 177 end loop; 178 179 Source_File.Free; 180 Sinput.Initialize; 181 end Clear_Source_File_Table; 182 183 -------------------- 184 -- Full_File_Name -- 185 -------------------- 186 function Full_File_Name (S : Source_File_Index) return File_Name_Type is 187 begin 188 return Source_File.Table (S).Full_File_Name; 189 end Full_File_Name; 190 191 ------------------- 192 -- Full_Ref_Name -- 193 ------------------- 194 195 function Full_Ref_Name (S : Source_File_Index) return File_Name_Type is 196 begin 197 return Source_File.Table (S).Full_Ref_Name; 198 end Full_Ref_Name; 199 200 ----------------------- 201 -- Get_Column_Number -- 202 ----------------------- 203 204 function Get_Column_Number (P : Source_Ptr) return Column_Number is 205 S : Source_Ptr; 206 C : Column_Number; 207 Sindex : Source_File_Index; 208 Src : Source_Buffer_Ptr; 209 210 begin 211 -- If the input source pointer is not a meaningful value then return 212 -- at once with column number 1. This can happen for a file not found 213 -- condition for a file loaded indirectly by RTE, and also perhaps on 214 -- some unknown internal error conditions. In either case we certainly 215 -- don't want to blow up. 216 217 if P < 1 then 218 return 1; 219 220 else 221 Sindex := Get_Source_File_Index (P); 222 Src := Source_File.Table (Sindex).Source_Text; 223 S := Line_Start (P); 224 C := 1; 225 226 while S < P loop 227 if Src (S) = ASCII.HT then 228 C := (C - 1) / 8 * 8 + (8 + 1); 229 S := S + 1; 230 231 -- Deal with wide character case, but don't include brackets 232 -- notation in this circuit, since we know that this will 233 -- display unencoded (no one encodes brackets notation). 234 235 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then 236 C := C + 1; 237 Skip_Wide (Src, S); 238 239 -- Normal (non-wide) character case or brackets sequence 240 241 else 242 C := C + 1; 243 S := S + 1; 244 end if; 245 end loop; 246 247 return C; 248 end if; 249 end Get_Column_Number; 250 251 --------------------- 252 -- Get_Line_Number -- 253 --------------------- 254 255 function Get_Line_Number 256 (P : Source_Ptr) return Line_Number 257 is 258 Sfile : Source_File_Index; 259 Table : Lines_Table_Ptr; 260 Lo : Line_Number; 261 Hi : Line_Number; 262 Mid : Line_Number; 263 Loc : Source_Ptr; 264 265 begin 266 -- If the input source pointer is not a meaningful value then return 267 -- at once with line number 1. This can happen for a file not found 268 -- condition for a file loaded indirectly by RTE, and also perhaps on 269 -- some unknown internal error conditions. In either case we certainly 270 -- don't want to blow up. 271 272 if P < 1 then 273 return 1; 274 275 -- Otherwise we can do the binary search 276 277 else 278 Sfile := Get_Source_File_Index (P); 279 Loc := P; 280 Table := Source_File.Table (Sfile).Lines_Table; 281 Lo := 1; 282 Hi := Source_File.Table (Sfile).Last_Source_Line; 283 284 loop 285 Mid := (Lo + Hi) / 2; 286 287 if Loc < Table (Mid) then 288 Hi := Mid - 1; 289 290 else -- Loc >= Table (Mid) 291 292 if Mid = Hi or else 293 Loc < Table (Mid + 1) 294 then 295 return Mid; 296 else 297 Lo := Mid + 1; 298 end if; 299 300 end if; 301 302 end loop; 303 end if; 304 end Get_Line_Number; 305 306 --------------------------- 307 -- Get_Source_File_Index -- 308 --------------------------- 309 310 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is 311 begin 312 return Source_File_Index_Table (Int (S) / Source_Align); 313 end Get_Source_File_Index; 314 315 ---------------- 316 -- Initialize -- 317 ---------------- 318 319 procedure Initialize is 320 begin 321 Source_File.Init; 322 end Initialize; 323 324 ---------------------- 325 -- Last_Source_File -- 326 ---------------------- 327 328 function Last_Source_File return Source_File_Index is 329 begin 330 return Source_File.Last; 331 end Last_Source_File; 332 333 ---------------- 334 -- Line_Start -- 335 ---------------- 336 337 function Line_Start (P : Source_Ptr) return Source_Ptr is 338 Sindex : constant Source_File_Index := Get_Source_File_Index (P); 339 Src : constant Source_Buffer_Ptr := 340 Source_File.Table (Sindex).Source_Text; 341 Sfirst : constant Source_Ptr := 342 Source_File.Table (Sindex).Source_First; 343 S : Source_Ptr; 344 345 begin 346 S := P; 347 while S > Sfirst 348 and then Src (S - 1) /= ASCII.CR 349 and then Src (S - 1) /= ASCII.LF 350 loop 351 S := S - 1; 352 end loop; 353 354 return S; 355 end Line_Start; 356 357 function Line_Start 358 (L : Line_Number; 359 S : Source_File_Index) return Source_Ptr 360 is 361 begin 362 return Source_File.Table (S).Lines_Table (L); 363 end Line_Start; 364 365 --------------- 366 -- Load_File -- 367 --------------- 368 369 function Load_File (Path : String) return Source_File_Index is 370 Src : Source_Buffer_Ptr; 371 X : Source_File_Index; 372 Lo : Source_Ptr; 373 Hi : Source_Ptr; 374 375 Source_File_FD : File_Descriptor; 376 -- The file descriptor for the current source file. A negative value 377 -- indicates failure to open the specified source file. 378 379 Len : Integer; 380 -- Length of file (assume no more than 2 gigabytes of source) 381 382 Actual_Len : Integer; 383 384 Path_Id : File_Name_Type; 385 File_Id : File_Name_Type; 386 387 begin 388 if Path = "" then 389 return No_Source_File; 390 end if; 391 392 Source_File.Increment_Last; 393 X := Source_File.Last; 394 395 if X = Source_File.First then 396 Lo := First_Source_Ptr; 397 else 398 Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / 399 Source_Align) * Source_Align; 400 end if; 401 402 Name_Len := Path'Length; 403 Name_Buffer (1 .. Name_Len) := Path; 404 Path_Id := Name_Find; 405 Name_Buffer (Name_Len + 1) := ASCII.NUL; 406 407 -- Open the source FD, note that we open in binary mode, because as 408 -- documented in the spec, the caller is expected to handle either 409 -- DOS or Unix mode files, and there is no point in wasting time on 410 -- text translation when it is not required. 411 412 Source_File_FD := Open_Read (Name_Buffer'Address, Binary); 413 414 if Source_File_FD = Invalid_FD then 415 Source_File.Decrement_Last; 416 return No_Source_File; 417 418 end if; 419 420 Len := Integer (File_Length (Source_File_FD)); 421 422 -- Set Hi so that length is one more than the physical length, allowing 423 -- for the extra EOF character at the end of the buffer 424 425 Hi := Lo + Source_Ptr (Len); 426 427 -- Do the actual read operation 428 429 declare 430 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); 431 -- Physical buffer allocated 432 433 type Actual_Source_Ptr is access Actual_Source_Buffer; 434 -- This is the pointer type for the physical buffer allocated 435 436 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; 437 -- And this is the actual physical buffer 438 439 begin 440 -- Allocate source buffer, allowing extra character at end for EOF 441 442 -- Some systems have file types that require one read per line, 443 -- so read until we get the Len bytes or until there are no more 444 -- characters. 445 446 Hi := Lo; 447 loop 448 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); 449 Hi := Hi + Source_Ptr (Actual_Len); 450 exit when Actual_Len = Len or else Actual_Len <= 0; 451 end loop; 452 453 Actual_Ptr (Hi) := EOF; 454 455 -- Now we need to work out the proper virtual origin pointer to 456 -- return. This is exactly Actual_Ptr (0)'Address, but we have to 457 -- be careful to suppress checks to compute this address. 458 459 declare 460 pragma Suppress (All_Checks); 461 462 pragma Warnings (Off); 463 -- The following unchecked conversion is aliased safe, since it 464 -- is not used to create improperly aliased pointer values. 465 466 function To_Source_Buffer_Ptr is new 467 Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr); 468 469 pragma Warnings (On); 470 471 begin 472 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); 473 end; 474 end; 475 476 -- Read is complete, close the file and we are done (no need to test 477 -- status from close, since we have successfully read the file). 478 479 Close (Source_File_FD); 480 481 -- Get the file name, without path information 482 483 declare 484 Index : Positive := Path'Last; 485 486 begin 487 while Index > Path'First loop 488 exit when Path (Index - 1) = '/'; 489 exit when Path (Index - 1) = Directory_Separator; 490 Index := Index - 1; 491 end loop; 492 493 Name_Len := Path'Last - Index + 1; 494 Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last); 495 File_Id := Name_Find; 496 end; 497 498 declare 499 S : Source_File_Record renames Source_File.Table (X); 500 501 begin 502 S := (File_Name => File_Id, 503 Reference_Name => File_Id, 504 Debug_Source_Name => File_Id, 505 Full_Debug_Name => Path_Id, 506 Full_File_Name => Path_Id, 507 Full_Ref_Name => Path_Id, 508 Source_Text => Src, 509 Source_First => Lo, 510 Source_Last => Hi, 511 Source_Checksum => 0, 512 Last_Source_Line => 1, 513 Time_Stamp => Empty_Time_Stamp, 514 Lines_Table => null, 515 Lines_Table_Max => 1); 516 517 S.Lines_Table_Max := Lines_Initial; 518 S.Lines_Table := new Lines_Table_Type (1 .. Lines_Initial); 519 S.Lines_Table (1) := Lo; 520 end; 521 522 Set_Source_File_Index_Table (X); 523 524 if First then 525 Main_Source_File := X; 526 First := False; 527 end if; 528 529 return X; 530 end Load_File; 531 532 ---------------------- 533 -- Num_Source_Files -- 534 ---------------------- 535 536 function Num_Source_Files return Nat is 537 begin 538 return Int (Source_File.Last) - Int (Source_File.First) + 1; 539 end Num_Source_Files; 540 541 ---------------------- 542 -- Num_Source_Lines -- 543 ---------------------- 544 545 function Num_Source_Lines (S : Source_File_Index) return Nat is 546 begin 547 return Nat (Source_File.Table (S).Last_Source_Line); 548 end Num_Source_Lines; 549 550 -------------------- 551 -- Reference_Name -- 552 -------------------- 553 554 function Reference_Name (S : Source_File_Index) return File_Name_Type is 555 begin 556 return Source_File.Table (S).Reference_Name; 557 end Reference_Name; 558 559 ----------------- 560 -- Reset_First -- 561 ----------------- 562 563 procedure Reset_First is 564 begin 565 First := True; 566 end Reset_First; 567 568 -------------------------------- 569 -- Restore_Project_Scan_State -- 570 -------------------------------- 571 572 procedure Restore_Project_Scan_State 573 (Saved_State : Saved_Project_Scan_State) 574 is 575 begin 576 Restore_Scan_State (Saved_State.Scan_State); 577 Source := Saved_State.Source; 578 Current_Source_File := Saved_State.Current_Source_File; 579 end Restore_Project_Scan_State; 580 581 ----------------------------- 582 -- Save_Project_Scan_State -- 583 ----------------------------- 584 585 procedure Save_Project_Scan_State 586 (Saved_State : out Saved_Project_Scan_State) 587 is 588 begin 589 Save_Scan_State (Saved_State.Scan_State); 590 Saved_State.Source := Source; 591 Saved_State.Current_Source_File := Current_Source_File; 592 end Save_Project_Scan_State; 593 594 --------------------------------- 595 -- Set_Source_File_Index_Table -- 596 --------------------------------- 597 598 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is 599 Ind : Int; 600 SP : Source_Ptr; 601 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; 602 begin 603 SP := Source_File.Table (Xnew).Source_First; 604 pragma Assert (SP mod Source_Align = 0); 605 Ind := Int (SP) / Source_Align; 606 while SP <= SL loop 607 Source_File_Index_Table (Ind) := Xnew; 608 SP := SP + Source_Align; 609 Ind := Ind + 1; 610 end loop; 611 end Set_Source_File_Index_Table; 612 613 --------------- 614 -- Skip_Wide -- 615 --------------- 616 617 procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is 618 619 function Skip_Char return Character; 620 -- Function to skip one character of wide character escape sequence 621 622 --------------- 623 -- Skip_Char -- 624 --------------- 625 626 function Skip_Char return Character is 627 begin 628 P := P + 1; 629 return S (P - 1); 630 end Skip_Char; 631 632 function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); 633 634 Discard : UTF_32_Code; 635 pragma Warnings (Off, Discard); 636 637 -- Start of processing for Skip_Wide 638 639 begin 640 Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); 641 end Skip_Wide; 642 643 ---------------------------- 644 -- Source_File_Is_Subunit -- 645 ---------------------------- 646 647 function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is 648 begin 649 -- Nothing to do if X is no source file, so simply return False 650 651 if X = No_Source_File then 652 return False; 653 end if; 654 655 Err.Scanner.Initialize_Scanner (X, Err.Scanner.Ada); 656 657 -- No error for special characters that are used for preprocessing 658 659 Err.Scanner.Set_Special_Character ('#'); 660 Err.Scanner.Set_Special_Character ('$'); 661 662 Check_For_BOM; 663 664 -- We scan past junk to the first interesting compilation unit token, to 665 -- see if it is SEPARATE. We ignore WITH keywords during this and also 666 -- PRIVATE. The reason for ignoring PRIVATE is that it handles some 667 -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. 668 669 while Token = Tok_With 670 or else Token = Tok_Private 671 or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) 672 loop 673 Err.Scanner.Scan; 674 end loop; 675 676 Err.Scanner.Reset_Special_Characters; 677 678 return Token = Tok_Separate; 679 end Source_File_Is_Subunit; 680 681 ------------------ 682 -- Source_First -- 683 ------------------ 684 685 function Source_First (S : Source_File_Index) return Source_Ptr is 686 begin 687 return Source_File.Table (S).Source_First; 688 end Source_First; 689 690 ----------------- 691 -- Source_Last -- 692 ----------------- 693 694 function Source_Last (S : Source_File_Index) return Source_Ptr is 695 begin 696 return Source_File.Table (S).Source_Last; 697 end Source_Last; 698 699 ----------------- 700 -- Source_Text -- 701 ----------------- 702 703 function Source_Text (S : Source_File_Index) return Source_Buffer_Ptr is 704 begin 705 return Source_File.Table (S).Source_Text; 706 end Source_Text; 707 708end GPR.Sinput; 709