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