gcc/ada/sinput.adb

   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
  32 pragma Style_Checks (All_Checks);
  33 --  Subprograms not all in alpha order
  34
  35 with Atree;    use Atree;
  36 with Debug;    use Debug;
  37 with Opt;      use Opt;
  38 with Output;   use Output;
  39 with Scans;    use Scans;
  40 with Tree_IO;  use Tree_IO;
  41 with Widechar; use Widechar;
  42
  43 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
  44
  45 with System;         use System;
  46 with System.Memory;
  47 with System.WCh_Con; use System.WCh_Con;
  48
  49 with Unchecked_Conversion;
  50 with Unchecked_Deallocation;
  51
  52 package 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
1317 end Sinput;