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