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