1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S I N P U T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Style_Checks (All_Checks); 33-- Subprograms not all in alpha order 34 35with Atree; use Atree; 36with Debug; use Debug; 37with Opt; use Opt; 38with Output; use Output; 39with Scans; use Scans; 40with Tree_IO; use Tree_IO; 41with Widechar; use Widechar; 42 43with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; 44 45with System.Storage_Elements; 46with System.Memory; 47with System.WCh_Con; use System.WCh_Con; 48 49with Unchecked_Conversion; 50with Unchecked_Deallocation; 51 52package body Sinput is 53 54 use ASCII, System; 55 56 -- Routines to support conversion between types Lines_Table_Ptr, 57 -- Logical_Lines_Table_Ptr and System.Address. 58 59 pragma Warnings (Off); 60 -- These unchecked conversions are aliasing safe, since they are never 61 -- used to construct improperly aliased pointer values. 62 63 function To_Address is 64 new Unchecked_Conversion (Lines_Table_Ptr, Address); 65 66 function To_Address is 67 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address); 68 69 function To_Pointer is 70 new Unchecked_Conversion (Address, Lines_Table_Ptr); 71 72 function To_Pointer is 73 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr); 74 75 pragma Warnings (On); 76 77 ----------------------------- 78 -- Source_File_Index_Table -- 79 ----------------------------- 80 81 -- The Get_Source_File_Index function is called very frequently. Earlier 82 -- versions cached a single entry, but then reverted to a serial search, 83 -- and this proved to be a significant source of inefficiency. We then 84 -- switched to using a table with a start point followed by a serial 85 -- search. Now we make sure source buffers are on a reasonable boundary 86 -- (see Types.Source_Align), and we can just use a direct look up in the 87 -- following table. 88 89 -- Note that this array is pretty large, but in most operating systems 90 -- it will not be allocated in physical memory unless it is actually used. 91 92 Source_File_Index_Table : 93 array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; 94 95 --------------------------- 96 -- Add_Line_Tables_Entry -- 97 --------------------------- 98 99 procedure Add_Line_Tables_Entry 100 (S : in out Source_File_Record; 101 P : Source_Ptr) 102 is 103 LL : Physical_Line_Number; 104 105 begin 106 -- Reallocate the lines tables if necessary 107 108 -- Note: the reason we do not use the normal Table package 109 -- mechanism is that we have several of these tables. We could 110 -- use the new GNAT.Dynamic_Tables package and that would probably 111 -- be a good idea ??? 112 113 if S.Last_Source_Line = S.Lines_Table_Max then 114 Alloc_Line_Tables 115 (S, 116 Int (S.Last_Source_Line) * 117 ((100 + Alloc.Lines_Increment) / 100)); 118 119 if Debug_Flag_D then 120 Write_Str ("--> Reallocating lines table, size = "); 121 Write_Int (Int (S.Lines_Table_Max)); 122 Write_Eol; 123 end if; 124 end if; 125 126 S.Last_Source_Line := S.Last_Source_Line + 1; 127 LL := S.Last_Source_Line; 128 129 S.Lines_Table (LL) := P; 130 131 -- Deal with setting new entry in logical lines table if one is 132 -- present. Note that there is always space (because the call to 133 -- Alloc_Line_Tables makes sure both tables are the same length), 134 135 if S.Logical_Lines_Table /= null then 136 137 -- We can always set the entry from the previous one, because 138 -- the processing for a Source_Reference pragma ensures that 139 -- at least one entry following the pragma is set up correctly. 140 141 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1; 142 end if; 143 end Add_Line_Tables_Entry; 144 145 ----------------------- 146 -- Alloc_Line_Tables -- 147 ----------------------- 148 149 procedure Alloc_Line_Tables 150 (S : in out Source_File_Record; 151 New_Max : Nat) 152 is 153 subtype size_t is Memory.size_t; 154 155 New_Table : Lines_Table_Ptr; 156 157 New_Logical_Table : Logical_Lines_Table_Ptr; 158 159 New_Size : constant size_t := 160 size_t (New_Max * Lines_Table_Type'Component_Size / 161 Storage_Unit); 162 163 begin 164 if S.Lines_Table = null then 165 New_Table := To_Pointer (Memory.Alloc (New_Size)); 166 167 else 168 New_Table := 169 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size)); 170 end if; 171 172 if New_Table = null then 173 raise Storage_Error; 174 else 175 S.Lines_Table := New_Table; 176 S.Lines_Table_Max := Physical_Line_Number (New_Max); 177 end if; 178 179 if S.Num_SRef_Pragmas /= 0 then 180 if S.Logical_Lines_Table = null then 181 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size)); 182 else 183 New_Logical_Table := To_Pointer 184 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size)); 185 end if; 186 187 if New_Logical_Table = null then 188 raise Storage_Error; 189 else 190 S.Logical_Lines_Table := New_Logical_Table; 191 end if; 192 end if; 193 end Alloc_Line_Tables; 194 195 ----------------- 196 -- Backup_Line -- 197 ----------------- 198 199 procedure Backup_Line (P : in out Source_Ptr) is 200 Sindex : constant Source_File_Index := Get_Source_File_Index (P); 201 Src : constant Source_Buffer_Ptr := 202 Source_File.Table (Sindex).Source_Text; 203 Sfirst : constant Source_Ptr := 204 Source_File.Table (Sindex).Source_First; 205 206 begin 207 P := P - 1; 208 209 if P = Sfirst then 210 return; 211 end if; 212 213 if Src (P) = CR then 214 if Src (P - 1) = LF then 215 P := P - 1; 216 end if; 217 218 else -- Src (P) = LF 219 if Src (P - 1) = CR then 220 P := P - 1; 221 end if; 222 end if; 223 224 -- Now find first character of the previous line 225 226 while P > Sfirst 227 and then Src (P - 1) /= LF 228 and then Src (P - 1) /= CR 229 loop 230 P := P - 1; 231 end loop; 232 end Backup_Line; 233 234 --------------------------- 235 -- Build_Location_String -- 236 --------------------------- 237 238 procedure Build_Location_String 239 (Buf : in out Bounded_String; 240 Loc : Source_Ptr) 241 is 242 Ptr : Source_Ptr := Loc; 243 244 begin 245 -- Loop through instantiations 246 247 loop 248 Append (Buf, Reference_Name (Get_Source_File_Index (Ptr))); 249 Append (Buf, ':'); 250 Append (Buf, Nat (Get_Logical_Line_Number (Ptr))); 251 252 Ptr := Instantiation_Location (Ptr); 253 exit when Ptr = No_Location; 254 Append (Buf, " instantiated at "); 255 end loop; 256 end Build_Location_String; 257 258 function Build_Location_String (Loc : Source_Ptr) return String is 259 Buf : Bounded_String; 260 begin 261 Build_Location_String (Buf, Loc); 262 return +Buf; 263 end Build_Location_String; 264 265 ------------------- 266 -- Check_For_BOM -- 267 ------------------- 268 269 procedure Check_For_BOM is 270 BOM : BOM_Kind; 271 Len : Natural; 272 Tst : String (1 .. 5); 273 C : Character; 274 275 begin 276 for J in 1 .. 5 loop 277 C := Source (Scan_Ptr + Source_Ptr (J) - 1); 278 279 -- Definitely no BOM if EOF character marks either end of file, or 280 -- an illegal non-BOM character if not at the end of file. 281 282 if C = EOF then 283 return; 284 end if; 285 286 Tst (J) := C; 287 end loop; 288 289 Read_BOM (Tst, Len, BOM, XML_Support => False); 290 291 case BOM is 292 when UTF8_All => 293 Scan_Ptr := Scan_Ptr + Source_Ptr (Len); 294 First_Non_Blank_Location := Scan_Ptr; 295 Current_Line_Start := Scan_Ptr; 296 Wide_Character_Encoding_Method := WCEM_UTF8; 297 Upper_Half_Encoding := True; 298 299 when UTF16_BE 300 | UTF16_LE 301 => 302 Set_Standard_Error; 303 Write_Line ("UTF-16 encoding format not recognized"); 304 Set_Standard_Output; 305 raise Unrecoverable_Error; 306 307 when UTF32_BE 308 | UTF32_LE 309 => 310 Set_Standard_Error; 311 Write_Line ("UTF-32 encoding format not recognized"); 312 Set_Standard_Output; 313 raise Unrecoverable_Error; 314 315 when Unknown => 316 null; 317 318 when others => 319 raise Program_Error; 320 end case; 321 end Check_For_BOM; 322 323 ----------------------------- 324 -- Clear_Source_File_Table -- 325 ----------------------------- 326 327 procedure Free is new Unchecked_Deallocation 328 (Lines_Table_Type, Lines_Table_Ptr); 329 330 procedure Free is new Unchecked_Deallocation 331 (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr); 332 333 procedure Clear_Source_File_Table is 334 begin 335 for X in 1 .. Source_File.Last loop 336 declare 337 S : Source_File_Record renames Source_File.Table (X); 338 begin 339 if S.Instance = No_Instance_Id then 340 Free_Source_Buffer (S.Source_Text); 341 else 342 Free_Dope (S.Source_Text'Address); 343 S.Source_Text := null; 344 end if; 345 346 Free (S.Lines_Table); 347 Free (S.Logical_Lines_Table); 348 end; 349 end loop; 350 351 Source_File.Free; 352 Sinput.Initialize; 353 end Clear_Source_File_Table; 354 355 --------------------------------- 356 -- Comes_From_Inherited_Pragma -- 357 --------------------------------- 358 359 function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is 360 SIE : Source_File_Record renames 361 Source_File.Table (Get_Source_File_Index (S)); 362 begin 363 return SIE.Inherited_Pragma; 364 end Comes_From_Inherited_Pragma; 365 366 ----------------------------- 367 -- Comes_From_Inlined_Body -- 368 ----------------------------- 369 370 function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is 371 SIE : Source_File_Record renames 372 Source_File.Table (Get_Source_File_Index (S)); 373 begin 374 return SIE.Inlined_Body; 375 end Comes_From_Inlined_Body; 376 377 ------------------------ 378 -- Free_Source_Buffer -- 379 ------------------------ 380 381 procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is 382 -- Unchecked_Deallocation doesn't work for access-to-constant; we need 383 -- to first Unchecked_Convert to access-to-variable. 384 385 function To_Source_Buffer_Ptr_Var is new 386 Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var); 387 388 Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src); 389 390 procedure Free_Ptr is new 391 Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var); 392 begin 393 Free_Ptr (Temp); 394 Src := null; 395 end Free_Source_Buffer; 396 397 ----------------------- 398 -- Get_Column_Number -- 399 ----------------------- 400 401 function Get_Column_Number (P : Source_Ptr) return Column_Number is 402 S : Source_Ptr; 403 C : Column_Number; 404 Sindex : Source_File_Index; 405 Src : Source_Buffer_Ptr; 406 407 begin 408 -- If the input source pointer is not a meaningful value then return 409 -- at once with column number 1. This can happen for a file not found 410 -- condition for a file loaded indirectly by RTE, and also perhaps on 411 -- some unknown internal error conditions. In either case we certainly 412 -- don't want to blow up. 413 414 if P < 1 then 415 return 1; 416 417 else 418 Sindex := Get_Source_File_Index (P); 419 Src := Source_File.Table (Sindex).Source_Text; 420 S := Line_Start (P); 421 C := 1; 422 423 while S < P loop 424 if Src (S) = HT then 425 C := (C - 1) / 8 * 8 + (8 + 1); 426 S := S + 1; 427 428 -- Deal with wide character case, but don't include brackets 429 -- notation in this circuit, since we know that this will 430 -- display unencoded (no one encodes brackets notation). 431 432 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then 433 C := C + 1; 434 Skip_Wide (Src, S); 435 436 -- Normal (non-wide) character case or brackets sequence 437 438 else 439 C := C + 1; 440 S := S + 1; 441 end if; 442 end loop; 443 444 return C; 445 end if; 446 end Get_Column_Number; 447 448 ----------------------------- 449 -- Get_Logical_Line_Number -- 450 ----------------------------- 451 452 function Get_Logical_Line_Number 453 (P : Source_Ptr) return Logical_Line_Number 454 is 455 SFR : Source_File_Record 456 renames Source_File.Table (Get_Source_File_Index (P)); 457 458 L : constant Physical_Line_Number := Get_Physical_Line_Number (P); 459 460 begin 461 if SFR.Num_SRef_Pragmas = 0 then 462 return Logical_Line_Number (L); 463 else 464 return SFR.Logical_Lines_Table (L); 465 end if; 466 end Get_Logical_Line_Number; 467 468 --------------------------------- 469 -- Get_Logical_Line_Number_Img -- 470 --------------------------------- 471 472 function Get_Logical_Line_Number_Img 473 (P : Source_Ptr) return String 474 is 475 begin 476 Name_Len := 0; 477 Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P))); 478 return Name_Buffer (1 .. Name_Len); 479 end Get_Logical_Line_Number_Img; 480 481 ------------------------------ 482 -- Get_Physical_Line_Number -- 483 ------------------------------ 484 485 function Get_Physical_Line_Number 486 (P : Source_Ptr) return Physical_Line_Number 487 is 488 Sfile : Source_File_Index; 489 Table : Lines_Table_Ptr; 490 Lo : Physical_Line_Number; 491 Hi : Physical_Line_Number; 492 Mid : Physical_Line_Number; 493 Loc : Source_Ptr; 494 495 begin 496 -- If the input source pointer is not a meaningful value then return 497 -- at once with line number 1. This can happen for a file not found 498 -- condition for a file loaded indirectly by RTE, and also perhaps on 499 -- some unknown internal error conditions. In either case we certainly 500 -- don't want to blow up. 501 502 if P < 1 then 503 return 1; 504 505 -- Otherwise we can do the binary search 506 507 else 508 Sfile := Get_Source_File_Index (P); 509 Loc := P + Source_File.Table (Sfile).Sloc_Adjust; 510 Table := Source_File.Table (Sfile).Lines_Table; 511 Lo := 1; 512 Hi := Source_File.Table (Sfile).Last_Source_Line; 513 514 loop 515 Mid := (Lo + Hi) / 2; 516 517 if Loc < Table (Mid) then 518 Hi := Mid - 1; 519 520 else -- Loc >= Table (Mid) 521 522 if Mid = Hi or else 523 Loc < Table (Mid + 1) 524 then 525 return Mid; 526 else 527 Lo := Mid + 1; 528 end if; 529 530 end if; 531 532 end loop; 533 end if; 534 end Get_Physical_Line_Number; 535 536 --------------------------- 537 -- Get_Source_File_Index -- 538 --------------------------- 539 540 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is 541 Result : Source_File_Index; 542 543 procedure Assertions; 544 -- Assert various properties of the result 545 546 procedure Assertions is 547 548 -- ???The old version using zero-origin array indexing without array 549 -- bounds checks returned 1 (i.e. system.ads) for these special 550 -- locations, presumably by accident. We are mimicing that here. 551 552 Special : constant Boolean := 553 S = No_Location 554 or else S = Standard_Location 555 or else S = Standard_ASCII_Location 556 or else S = System_Location; 557 558 pragma Assert ((S > No_Location) xor Special); 559 pragma Assert (Result in Source_File.First .. Source_File.Last); 560 561 SFR : Source_File_Record renames Source_File.Table (Result); 562 563 begin 564 -- SFR.Source_Text = null if and only if this is the SFR for a debug 565 -- output file (*.dg), and that file is under construction. S can be 566 -- slightly past Source_Last in that case because we haven't updated 567 -- Source_Last. 568 569 if Null_Source_Buffer_Ptr (SFR.Source_Text) then 570 pragma Assert (S >= SFR.Source_First); null; 571 else 572 pragma Assert (SFR.Source_Text'First = SFR.Source_First); 573 pragma Assert (SFR.Source_Text'Last = SFR.Source_Last); 574 575 if not Special then 576 pragma Assert (S in SFR.Source_First .. SFR.Source_Last); 577 null; 578 end if; 579 end if; 580 end Assertions; 581 582 -- Start of processing for Get_Source_File_Index 583 584 begin 585 if S > No_Location then 586 Result := Source_File_Index_Table (Int (S) / Source_Align); 587 else 588 Result := 1; 589 end if; 590 591 pragma Debug (Assertions); 592 593 return Result; 594 end Get_Source_File_Index; 595 596 ---------------- 597 -- Initialize -- 598 ---------------- 599 600 procedure Initialize is 601 begin 602 Source_gnat_adc := No_Source_File; 603 Source_File.Init; 604 Instances.Init; 605 Instances.Append (No_Location); 606 pragma Assert (Instances.Last = No_Instance_Id); 607 end Initialize; 608 609 ------------------- 610 -- Instantiation -- 611 ------------------- 612 613 function Instantiation (S : SFI) return Source_Ptr is 614 SIE : Source_File_Record renames Source_File.Table (S); 615 begin 616 if SIE.Inlined_Body or SIE.Inherited_Pragma then 617 return SIE.Inlined_Call; 618 else 619 return Instances.Table (SIE.Instance); 620 end if; 621 end Instantiation; 622 623 ------------------------- 624 -- Instantiation_Depth -- 625 ------------------------- 626 627 function Instantiation_Depth (S : Source_Ptr) return Nat is 628 Sind : Source_File_Index; 629 Sval : Source_Ptr; 630 Depth : Nat; 631 632 begin 633 Sval := S; 634 Depth := 0; 635 636 loop 637 Sind := Get_Source_File_Index (Sval); 638 Sval := Instantiation (Sind); 639 exit when Sval = No_Location; 640 Depth := Depth + 1; 641 end loop; 642 643 return Depth; 644 end Instantiation_Depth; 645 646 ---------------------------- 647 -- Instantiation_Location -- 648 ---------------------------- 649 650 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is 651 begin 652 return Instantiation (Get_Source_File_Index (S)); 653 end Instantiation_Location; 654 655 -------------------------- 656 -- Iterate_On_Instances -- 657 -------------------------- 658 659 procedure Iterate_On_Instances is 660 begin 661 for J in 1 .. Instances.Last loop 662 Process (J, Instances.Table (J)); 663 end loop; 664 end Iterate_On_Instances; 665 666 ---------------------- 667 -- Last_Source_File -- 668 ---------------------- 669 670 function Last_Source_File return Source_File_Index is 671 begin 672 return Source_File.Last; 673 end Last_Source_File; 674 675 ---------------- 676 -- Line_Start -- 677 ---------------- 678 679 function Line_Start (P : Source_Ptr) return Source_Ptr is 680 Sindex : constant Source_File_Index := Get_Source_File_Index (P); 681 Src : constant Source_Buffer_Ptr := 682 Source_File.Table (Sindex).Source_Text; 683 Sfirst : constant Source_Ptr := 684 Source_File.Table (Sindex).Source_First; 685 S : Source_Ptr; 686 687 begin 688 S := P; 689 while S > Sfirst 690 and then Src (S - 1) /= CR 691 and then Src (S - 1) /= LF 692 loop 693 S := S - 1; 694 end loop; 695 696 return S; 697 end Line_Start; 698 699 function Line_Start 700 (L : Physical_Line_Number; 701 S : Source_File_Index) return Source_Ptr 702 is 703 begin 704 return Source_File.Table (S).Lines_Table (L); 705 end Line_Start; 706 707 ---------- 708 -- Lock -- 709 ---------- 710 711 procedure Lock is 712 begin 713 Source_File.Release; 714 Source_File.Locked := True; 715 end Lock; 716 717 ---------------------- 718 -- Num_Source_Files -- 719 ---------------------- 720 721 function Num_Source_Files return Nat is 722 begin 723 return Int (Source_File.Last) - Int (Source_File.First) + 1; 724 end Num_Source_Files; 725 726 ---------------------- 727 -- Num_Source_Lines -- 728 ---------------------- 729 730 function Num_Source_Lines (S : Source_File_Index) return Nat is 731 begin 732 return Nat (Source_File.Table (S).Last_Source_Line); 733 end Num_Source_Lines; 734 735 ----------------------- 736 -- Original_Location -- 737 ----------------------- 738 739 function Original_Location (S : Source_Ptr) return Source_Ptr is 740 Sindex : Source_File_Index; 741 Tindex : Source_File_Index; 742 743 begin 744 if S <= No_Location then 745 return S; 746 747 else 748 Sindex := Get_Source_File_Index (S); 749 750 if Instantiation (Sindex) = No_Location then 751 return S; 752 753 else 754 Tindex := Template (Sindex); 755 while Instantiation (Tindex) /= No_Location loop 756 Tindex := Template (Tindex); 757 end loop; 758 759 return S - Source_First (Sindex) + Source_First (Tindex); 760 end if; 761 end if; 762 end Original_Location; 763 764 ------------------------- 765 -- Physical_To_Logical -- 766 ------------------------- 767 768 function Physical_To_Logical 769 (Line : Physical_Line_Number; 770 S : Source_File_Index) return Logical_Line_Number 771 is 772 SFR : Source_File_Record renames Source_File.Table (S); 773 774 begin 775 if SFR.Num_SRef_Pragmas = 0 then 776 return Logical_Line_Number (Line); 777 else 778 return SFR.Logical_Lines_Table (Line); 779 end if; 780 end Physical_To_Logical; 781 782 -------------------------------- 783 -- Register_Source_Ref_Pragma -- 784 -------------------------------- 785 786 procedure Register_Source_Ref_Pragma 787 (File_Name : File_Name_Type; 788 Stripped_File_Name : File_Name_Type; 789 Mapped_Line : Nat; 790 Line_After_Pragma : Physical_Line_Number) 791 is 792 subtype size_t is Memory.size_t; 793 794 SFR : Source_File_Record renames Source_File.Table (Current_Source_File); 795 796 ML : Logical_Line_Number; 797 798 begin 799 if File_Name /= No_File then 800 SFR.Reference_Name := Stripped_File_Name; 801 SFR.Full_Ref_Name := File_Name; 802 803 if not Debug_Generated_Code then 804 SFR.Debug_Source_Name := Stripped_File_Name; 805 SFR.Full_Debug_Name := File_Name; 806 end if; 807 808 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1; 809 end if; 810 811 if SFR.Num_SRef_Pragmas = 1 then 812 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line); 813 end if; 814 815 if SFR.Logical_Lines_Table = null then 816 SFR.Logical_Lines_Table := To_Pointer 817 (Memory.Alloc 818 (size_t (SFR.Lines_Table_Max * 819 Logical_Lines_Table_Type'Component_Size / 820 Storage_Unit))); 821 end if; 822 823 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number; 824 825 ML := Logical_Line_Number (Mapped_Line); 826 for J in Line_After_Pragma .. SFR.Last_Source_Line loop 827 SFR.Logical_Lines_Table (J) := ML; 828 ML := ML + 1; 829 end loop; 830 end Register_Source_Ref_Pragma; 831 832 --------------------------------- 833 -- Set_Source_File_Index_Table -- 834 --------------------------------- 835 836 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is 837 Ind : Int; 838 SP : Source_Ptr; 839 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; 840 begin 841 SP := Source_File.Table (Xnew).Source_First; 842 pragma Assert (SP mod Source_Align = 0); 843 Ind := Int (SP) / Source_Align; 844 while SP <= SL loop 845 Source_File_Index_Table (Ind) := Xnew; 846 SP := SP + Source_Align; 847 Ind := Ind + 1; 848 end loop; 849 end Set_Source_File_Index_Table; 850 851 --------------------------- 852 -- Skip_Line_Terminators -- 853 --------------------------- 854 855 procedure Skip_Line_Terminators 856 (P : in out Source_Ptr; 857 Physical : out Boolean) 858 is 859 Chr : constant Character := Source (P); 860 861 begin 862 if Chr = CR then 863 if Source (P + 1) = LF then 864 P := P + 2; 865 else 866 P := P + 1; 867 end if; 868 869 elsif Chr = LF then 870 P := P + 1; 871 872 elsif Chr = FF or else Chr = VT then 873 P := P + 1; 874 Physical := False; 875 return; 876 877 -- Otherwise we have a wide character 878 879 else 880 Skip_Wide (Source, P); 881 end if; 882 883 -- Fall through in the physical line terminator case. First deal with 884 -- making a possible entry into the lines table if one is needed. 885 886 -- Note: we are dealing with a real source file here, this cannot be 887 -- the instantiation case, so we need not worry about Sloc adjustment. 888 889 declare 890 S : Source_File_Record 891 renames Source_File.Table (Current_Source_File); 892 893 begin 894 Physical := True; 895 896 -- Make entry in lines table if not already made (in some scan backup 897 -- cases, we will be rescanning previously scanned source, so the 898 -- entry may have already been made on the previous forward scan). 899 900 if Source (P) /= EOF 901 and then P > S.Lines_Table (S.Last_Source_Line) 902 then 903 Add_Line_Tables_Entry (S, P); 904 end if; 905 end; 906 end Skip_Line_Terminators; 907 908 -------------- 909 -- Set_Dope -- 910 -------------- 911 912 procedure Set_Dope 913 (Src : System.Address; New_Dope : Dope_Ptr) 914 is 915 -- A fat pointer is a pair consisting of data pointer and dope pointer, 916 -- in that order. So we want to overwrite the second word. 917 Dope : System.Address; 918 pragma Import (Ada, Dope); 919 use System.Storage_Elements; 920 for Dope'Address use Src + System.Address'Size / 8; 921 begin 922 Dope := New_Dope.all'Address; 923 end Set_Dope; 924 925 procedure Free_Dope (Src : System.Address) is 926 Dope : Dope_Ptr; 927 pragma Import (Ada, Dope); 928 use System.Storage_Elements; 929 for Dope'Address use Src + System.Address'Size / 8; 930 procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr); 931 begin 932 Free (Dope); 933 end Free_Dope; 934 935 ---------------- 936 -- Sloc_Range -- 937 ---------------- 938 939 procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is 940 941 function Process (N : Node_Id) return Traverse_Result; 942 -- Process function for traversing the node tree 943 944 procedure Traverse is new Traverse_Proc (Process); 945 946 ------------- 947 -- Process -- 948 ------------- 949 950 function Process (N : Node_Id) return Traverse_Result is 951 Orig : constant Node_Id := Original_Node (N); 952 953 begin 954 if Sloc (Orig) < Min then 955 if Sloc (Orig) > No_Location then 956 Min := Sloc (Orig); 957 end if; 958 959 elsif Sloc (Orig) > Max then 960 if Sloc (Orig) > No_Location then 961 Max := Sloc (Orig); 962 end if; 963 end if; 964 965 return OK_Orig; 966 end Process; 967 968 -- Start of processing for Sloc_Range 969 970 begin 971 Min := Sloc (N); 972 Max := Sloc (N); 973 Traverse (N); 974 end Sloc_Range; 975 976 ------------------- 977 -- Source_Offset -- 978 ------------------- 979 980 function Source_Offset (S : Source_Ptr) return Nat is 981 Sindex : constant Source_File_Index := Get_Source_File_Index (S); 982 Sfirst : constant Source_Ptr := 983 Source_File.Table (Sindex).Source_First; 984 begin 985 return Nat (S - Sfirst); 986 end Source_Offset; 987 988 ------------------------ 989 -- Top_Level_Location -- 990 ------------------------ 991 992 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is 993 Oldloc : Source_Ptr; 994 Newloc : Source_Ptr; 995 996 begin 997 Newloc := S; 998 loop 999 Oldloc := Newloc; 1000 Newloc := Instantiation_Location (Oldloc); 1001 exit when Newloc = No_Location; 1002 end loop; 1003 1004 return Oldloc; 1005 end Top_Level_Location; 1006 1007 --------------- 1008 -- Tree_Read -- 1009 --------------- 1010 1011 procedure Tree_Read is 1012 begin 1013 -- First we must free any old source buffer pointers 1014 1015 for J in Source_File.First .. Source_File.Last loop 1016 declare 1017 S : Source_File_Record renames Source_File.Table (J); 1018 begin 1019 if S.Instance = No_Instance_Id then 1020 Free_Source_Buffer (S.Source_Text); 1021 1022 if S.Lines_Table /= null then 1023 Memory.Free (To_Address (S.Lines_Table)); 1024 S.Lines_Table := null; 1025 end if; 1026 1027 if S.Logical_Lines_Table /= null then 1028 Memory.Free (To_Address (S.Logical_Lines_Table)); 1029 S.Logical_Lines_Table := null; 1030 end if; 1031 1032 else 1033 Free_Dope (S.Source_Text'Address); 1034 S.Source_Text := null; 1035 end if; 1036 end; 1037 end loop; 1038 1039 -- Read in source file table and instance table 1040 1041 Source_File.Tree_Read; 1042 Instances.Tree_Read; 1043 1044 -- The pointers we read in there for the source buffer and lines table 1045 -- pointers are junk. We now read in the actual data that is referenced 1046 -- by these two fields. 1047 1048 for J in Source_File.First .. Source_File.Last loop 1049 declare 1050 S : Source_File_Record renames Source_File.Table (J); 1051 begin 1052 -- Normal case (non-instantiation) 1053 1054 if S.Instance = No_Instance_Id then 1055 S.Lines_Table := null; 1056 S.Logical_Lines_Table := null; 1057 Alloc_Line_Tables (S, Int (S.Last_Source_Line)); 1058 1059 for J in 1 .. S.Last_Source_Line loop 1060 Tree_Read_Int (Int (S.Lines_Table (J))); 1061 end loop; 1062 1063 if S.Num_SRef_Pragmas /= 0 then 1064 for J in 1 .. S.Last_Source_Line loop 1065 Tree_Read_Int (Int (S.Logical_Lines_Table (J))); 1066 end loop; 1067 end if; 1068 1069 -- Allocate source buffer and read in the data 1070 1071 declare 1072 T : constant Source_Buffer_Ptr_Var := 1073 new Source_Buffer (S.Source_First .. S.Source_Last); 1074 begin 1075 Tree_Read_Data (T (S.Source_First)'Address, 1076 Int (S.Source_Last) - Int (S.Source_First) + 1); 1077 S.Source_Text := T.all'Access; 1078 end; 1079 1080 -- For the instantiation case, we do not read in any data. Instead 1081 -- we share the data for the generic template entry. Since the 1082 -- template always occurs first, we can safely refer to its data. 1083 1084 else 1085 declare 1086 ST : Source_File_Record renames 1087 Source_File.Table (S.Template); 1088 1089 begin 1090 -- The lines tables are copied from the template entry 1091 1092 S.Lines_Table := ST.Lines_Table; 1093 S.Logical_Lines_Table := ST.Logical_Lines_Table; 1094 1095 -- The Source_Text of the instance is the same data as that 1096 -- of the template, but with different bounds. 1097 1098 declare 1099 Dope : constant Dope_Ptr := 1100 new Dope_Rec'(S.Source_First, S.Source_Last); 1101 begin 1102 S.Source_Text := ST.Source_Text; 1103 Set_Dope (S.Source_Text'Address, Dope); 1104 end; 1105 end; 1106 end if; 1107 end; 1108 1109 Set_Source_File_Index_Table (J); 1110 end loop; 1111 end Tree_Read; 1112 1113 ---------------- 1114 -- Tree_Write -- 1115 ---------------- 1116 1117 procedure Tree_Write is 1118 begin 1119 Source_File.Tree_Write; 1120 Instances.Tree_Write; 1121 1122 -- The pointers we wrote out there for the source buffer and lines 1123 -- table pointers are junk, we now write out the actual data that 1124 -- is referenced by these two fields. 1125 1126 for J in Source_File.First .. Source_File.Last loop 1127 declare 1128 S : Source_File_Record renames Source_File.Table (J); 1129 1130 begin 1131 -- For instantiations, there is nothing to do, since the data is 1132 -- shared with the generic template. When the tree is read, the 1133 -- pointers must be set, but no extra data needs to be written. 1134 -- For the normal case, write out the data of the tables. 1135 1136 if S.Instance = No_Instance_Id then 1137 -- Lines table 1138 1139 for J in 1 .. S.Last_Source_Line loop 1140 Tree_Write_Int (Int (S.Lines_Table (J))); 1141 end loop; 1142 1143 -- Logical lines table if present 1144 1145 if S.Num_SRef_Pragmas /= 0 then 1146 for J in 1 .. S.Last_Source_Line loop 1147 Tree_Write_Int (Int (S.Logical_Lines_Table (J))); 1148 end loop; 1149 end if; 1150 1151 -- Source buffer 1152 1153 Tree_Write_Data 1154 (S.Source_Text (S.Source_First)'Address, 1155 Int (S.Source_Last) - Int (S.Source_First) + 1); 1156 end if; 1157 end; 1158 end loop; 1159 end Tree_Write; 1160 1161 -------------------- 1162 -- Write_Location -- 1163 -------------------- 1164 1165 procedure Write_Location (P : Source_Ptr) is 1166 begin 1167 if P = No_Location then 1168 Write_Str ("<no location>"); 1169 1170 elsif P <= Standard_Location then 1171 Write_Str ("<standard location>"); 1172 1173 else 1174 declare 1175 SI : constant Source_File_Index := Get_Source_File_Index (P); 1176 1177 begin 1178 Write_Name (Debug_Source_Name (SI)); 1179 Write_Char (':'); 1180 Write_Int (Int (Get_Logical_Line_Number (P))); 1181 Write_Char (':'); 1182 Write_Int (Int (Get_Column_Number (P))); 1183 1184 if Instantiation (SI) /= No_Location then 1185 Write_Str (" ["); 1186 Write_Location (Instantiation (SI)); 1187 Write_Char (']'); 1188 end if; 1189 end; 1190 end if; 1191 end Write_Location; 1192 1193 ---------------------- 1194 -- Write_Time_Stamp -- 1195 ---------------------- 1196 1197 procedure Write_Time_Stamp (S : Source_File_Index) is 1198 T : constant Time_Stamp_Type := Time_Stamp (S); 1199 P : Natural; 1200 1201 begin 1202 if T (1) = '9' then 1203 Write_Str ("19"); 1204 P := 0; 1205 else 1206 Write_Char (T (1)); 1207 Write_Char (T (2)); 1208 P := 2; 1209 end if; 1210 1211 Write_Char (T (P + 1)); 1212 Write_Char (T (P + 2)); 1213 Write_Char ('-'); 1214 1215 Write_Char (T (P + 3)); 1216 Write_Char (T (P + 4)); 1217 Write_Char ('-'); 1218 1219 Write_Char (T (P + 5)); 1220 Write_Char (T (P + 6)); 1221 Write_Char (' '); 1222 1223 Write_Char (T (P + 7)); 1224 Write_Char (T (P + 8)); 1225 Write_Char (':'); 1226 1227 Write_Char (T (P + 9)); 1228 Write_Char (T (P + 10)); 1229 Write_Char (':'); 1230 1231 Write_Char (T (P + 11)); 1232 Write_Char (T (P + 12)); 1233 end Write_Time_Stamp; 1234 1235 ---------------------------------------------- 1236 -- Access Subprograms for Source File Table -- 1237 ---------------------------------------------- 1238 1239 function Debug_Source_Name (S : SFI) return File_Name_Type is 1240 begin 1241 return Source_File.Table (S).Debug_Source_Name; 1242 end Debug_Source_Name; 1243 1244 function Instance (S : SFI) return Instance_Id is 1245 begin 1246 return Source_File.Table (S).Instance; 1247 end Instance; 1248 1249 function File_Name (S : SFI) return File_Name_Type is 1250 begin 1251 return Source_File.Table (S).File_Name; 1252 end File_Name; 1253 1254 function File_Type (S : SFI) return Type_Of_File is 1255 begin 1256 return Source_File.Table (S).File_Type; 1257 end File_Type; 1258 1259 function First_Mapped_Line (S : SFI) return Logical_Line_Number is 1260 begin 1261 return Source_File.Table (S).First_Mapped_Line; 1262 end First_Mapped_Line; 1263 1264 function Full_Debug_Name (S : SFI) return File_Name_Type is 1265 begin 1266 return Source_File.Table (S).Full_Debug_Name; 1267 end Full_Debug_Name; 1268 1269 function Full_File_Name (S : SFI) return File_Name_Type is 1270 begin 1271 return Source_File.Table (S).Full_File_Name; 1272 end Full_File_Name; 1273 1274 function Full_Ref_Name (S : SFI) return File_Name_Type is 1275 begin 1276 return Source_File.Table (S).Full_Ref_Name; 1277 end Full_Ref_Name; 1278 1279 function Identifier_Casing (S : SFI) return Casing_Type is 1280 begin 1281 return Source_File.Table (S).Identifier_Casing; 1282 end Identifier_Casing; 1283 1284 function Inherited_Pragma (S : SFI) return Boolean is 1285 begin 1286 return Source_File.Table (S).Inherited_Pragma; 1287 end Inherited_Pragma; 1288 1289 function Inlined_Body (S : SFI) return Boolean is 1290 begin 1291 return Source_File.Table (S).Inlined_Body; 1292 end Inlined_Body; 1293 1294 function Inlined_Call (S : SFI) return Source_Ptr is 1295 begin 1296 return Source_File.Table (S).Inlined_Call; 1297 end Inlined_Call; 1298 1299 function Keyword_Casing (S : SFI) return Casing_Type is 1300 begin 1301 return Source_File.Table (S).Keyword_Casing; 1302 end Keyword_Casing; 1303 1304 function Last_Source_Line (S : SFI) return Physical_Line_Number is 1305 begin 1306 return Source_File.Table (S).Last_Source_Line; 1307 end Last_Source_Line; 1308 1309 function License (S : SFI) return License_Type is 1310 begin 1311 return Source_File.Table (S).License; 1312 end License; 1313 1314 function Num_SRef_Pragmas (S : SFI) return Nat is 1315 begin 1316 return Source_File.Table (S).Num_SRef_Pragmas; 1317 end Num_SRef_Pragmas; 1318 1319 function Reference_Name (S : SFI) return File_Name_Type is 1320 begin 1321 return Source_File.Table (S).Reference_Name; 1322 end Reference_Name; 1323 1324 function Source_Checksum (S : SFI) return Word is 1325 begin 1326 return Source_File.Table (S).Source_Checksum; 1327 end Source_Checksum; 1328 1329 function Source_First (S : SFI) return Source_Ptr is 1330 begin 1331 return Source_File.Table (S).Source_First; 1332 end Source_First; 1333 1334 function Source_Last (S : SFI) return Source_Ptr is 1335 begin 1336 return Source_File.Table (S).Source_Last; 1337 end Source_Last; 1338 1339 function Source_Text (S : SFI) return Source_Buffer_Ptr is 1340 begin 1341 return Source_File.Table (S).Source_Text; 1342 end Source_Text; 1343 1344 function Template (S : SFI) return SFI is 1345 begin 1346 return Source_File.Table (S).Template; 1347 end Template; 1348 1349 function Time_Stamp (S : SFI) return Time_Stamp_Type is 1350 begin 1351 return Source_File.Table (S).Time_Stamp; 1352 end Time_Stamp; 1353 1354 function Unit (S : SFI) return Unit_Number_Type is 1355 begin 1356 return Source_File.Table (S).Unit; 1357 end Unit; 1358 1359 ------------------------------------------ 1360 -- Set Procedures for Source File Table -- 1361 ------------------------------------------ 1362 1363 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is 1364 begin 1365 Source_File.Table (S).Identifier_Casing := C; 1366 end Set_Identifier_Casing; 1367 1368 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is 1369 begin 1370 Source_File.Table (S).Keyword_Casing := C; 1371 end Set_Keyword_Casing; 1372 1373 procedure Set_License (S : SFI; L : License_Type) is 1374 begin 1375 Source_File.Table (S).License := L; 1376 end Set_License; 1377 1378 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is 1379 begin 1380 Source_File.Table (S).Unit := U; 1381 end Set_Unit; 1382 1383 ---------------------- 1384 -- Trim_Lines_Table -- 1385 ---------------------- 1386 1387 procedure Trim_Lines_Table (S : Source_File_Index) is 1388 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line); 1389 1390 begin 1391 -- Release allocated storage that is no longer needed 1392 1393 Source_File.Table (S).Lines_Table := To_Pointer 1394 (Memory.Realloc 1395 (To_Address (Source_File.Table (S).Lines_Table), 1396 Memory.size_t 1397 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit)))); 1398 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max); 1399 end Trim_Lines_Table; 1400 1401 ------------ 1402 -- Unlock -- 1403 ------------ 1404 1405 procedure Unlock is 1406 begin 1407 Source_File.Locked := False; 1408 Source_File.Release; 1409 end Unlock; 1410 1411 -------- 1412 -- wl -- 1413 -------- 1414 1415 procedure wl (P : Source_Ptr) is 1416 begin 1417 Write_Location (P); 1418 Write_Eol; 1419 end wl; 1420 1421end Sinput; 1422