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