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