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