gcc/ada/sinput-l.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S I N P U T . L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2012, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Alloc;
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Fname;    use Fname;
  32 with Hostparm;
  33 with Lib;      use Lib;
  34 with Opt;      use Opt;
  35 with Osint;    use Osint;
  36 with Output;   use Output;
  37 with Prep;     use Prep;
  38 with Prepcomp; use Prepcomp;
  39 with Scans;    use Scans;
  40 with Scn;      use Scn;
  41 with Sem_Aux;  use Sem_Aux;
  42 with Sem_Util; use Sem_Util;
  43 with Sinfo;    use Sinfo;
  44 with Snames;   use Snames;
  45 with System;   use System;
  46
  47 with System.OS_Lib; use System.OS_Lib;
  48
  49 with Unchecked_Conversion;
  50
  51 package body Sinput.L is
  52
  53    Prep_Buffer : Text_Buffer_Ptr := null;
  54    --  A buffer to temporarily stored the result of preprocessing a source.
  55    --  It is only allocated if there is at least one source to preprocess.
  56
  57    Prep_Buffer_Last : Text_Ptr := 0;
  58    --  Index of the last significant character in Prep_Buffer
  59
  60    Initial_Size_Of_Prep_Buffer : constant := 10_000;
  61    --  Size of Prep_Buffer when it is first allocated
  62
  63    --  When a file is to be preprocessed and the options to list symbols
  64    --  has been selected (switch -s), Prep.List_Symbols is called with a
  65    --  "foreword", a single line indicating what source the symbols apply to.
  66    --  The following two constant String are the start and the end of this
  67    --  foreword.
  68
  69    Foreword_Start : constant String :=
  70                       "Preprocessing Symbols for source """;
  71
  72    Foreword_End : constant String := """";
  73
  74    -----------------
  75    -- Subprograms --
  76    -----------------
  77
  78    procedure Put_Char_In_Prep_Buffer (C : Character);
  79    --  Add one character in Prep_Buffer, extending Prep_Buffer if need be.
  80    --  Used to initialize the preprocessor.
  81
  82    procedure New_EOL_In_Prep_Buffer;
  83    --  Add an LF to Prep_Buffer (used to initialize the preprocessor)
  84
  85    function Load_File
  86      (N : File_Name_Type;
  87       T : Osint.File_Type) return Source_File_Index;
  88    --  Load a source file, a configuration pragmas file or a definition file
  89    --  Coding also allows preprocessing file, but not a library file ???
  90
  91    -------------------------------
  92    -- Adjust_Instantiation_Sloc --
  93    -------------------------------
  94
  95    procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
  96       Loc : constant Source_Ptr := Sloc (N);
  97
  98    begin
  99       --  We only do the adjustment if the value is between the appropriate low
 100       --  and high values. It is not clear that this should ever not be the
 101       --  case, but in practice there seem to be some nodes that get copied
 102       --  twice, and this is a defence against that happening.
 103
 104       if A.Lo <= Loc and then Loc <= A.Hi then
 105          Set_Sloc (N, Loc + A.Adjust);
 106       end if;
 107    end Adjust_Instantiation_Sloc;
 108
 109    --------------------------------
 110    -- Complete_Source_File_Entry --
 111    --------------------------------
 112
 113    procedure Complete_Source_File_Entry is
 114       CSF : constant Source_File_Index := Current_Source_File;
 115
 116    begin
 117       Trim_Lines_Table (CSF);
 118       Source_File.Table (CSF).Source_Checksum := Checksum;
 119    end Complete_Source_File_Entry;
 120
 121    ---------------------------------
 122    -- Create_Instantiation_Source --
 123    ---------------------------------
 124
 125    procedure Create_Instantiation_Source
 126      (Inst_Node    : Entity_Id;
 127       Template_Id  : Entity_Id;
 128       Inlined_Body : Boolean;
 129       A            : out Sloc_Adjustment)
 130    is
 131       Dnod : constant Node_Id := Declaration_Node (Template_Id);
 132       Xold : Source_File_Index;
 133       Xnew : Source_File_Index;
 134
 135    begin
 136       Xold := Get_Source_File_Index (Sloc (Template_Id));
 137       A.Lo := Source_File.Table (Xold).Source_First;
 138       A.Hi := Source_File.Table (Xold).Source_Last;
 139
 140       Source_File.Append (Source_File.Table (Xold));
 141       Xnew := Source_File.Last;
 142
 143       declare
 144          Sold : Source_File_Record renames Source_File.Table (Xold);
 145          Snew : Source_File_Record renames Source_File.Table (Xnew);
 146
 147          Inst_Spec : Node_Id;
 148
 149       begin
 150          Snew.Inlined_Body  := Inlined_Body;
 151          Snew.Template      := Xold;
 152
 153          --  For a genuine generic instantiation, assign new instance id.
 154          --  For inlined bodies, we retain that of the template, but we
 155          --  save the call location.
 156
 157          if Inlined_Body then
 158             Snew.Inlined_Call := Sloc (Inst_Node);
 159
 160          else
 161
 162             --  If the spec has been instantiated already, and we are now
 163             --  creating the instance source for the corresponding body now,
 164             --  retrieve the instance id that was assigned to the spec, which
 165             --  corresponds to the same instantiation sloc.
 166
 167             Inst_Spec := Instance_Spec (Inst_Node);
 168             if Present (Inst_Spec) then
 169                declare
 170                   Inst_Spec_Ent     : Entity_Id;
 171                   --  Instance spec entity
 172
 173                   Inst_Spec_Sloc    : Source_Ptr;
 174                   --  Virtual sloc of the spec instance source
 175
 176                   Inst_Spec_Inst_Id : Instance_Id;
 177                   --  Instance id assigned to the instance spec
 178
 179                begin
 180                   Inst_Spec_Ent := Defining_Entity (Inst_Spec);
 181
 182                   --  For a subprogram instantiation, we want the subprogram
 183                   --  instance, not the wrapper package.
 184
 185                   if Present (Related_Instance (Inst_Spec_Ent)) then
 186                      Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent);
 187                   end if;
 188
 189                   --  The specification of the instance entity has a virtual
 190                   --  sloc within the instance sloc range.
 191                   --  ??? But the Unit_Declaration_Node has the sloc of the
 192                   --  instantiation, which is somewhat of an oddity.
 193
 194                   Inst_Spec_Sloc    :=
 195                     Sloc (Specification (Unit_Declaration_Node
 196                                            (Inst_Spec_Ent)));
 197                   Inst_Spec_Inst_Id :=
 198                     Source_File.Table
 199                       (Get_Source_File_Index (Inst_Spec_Sloc)).Instance;
 200
 201                   pragma Assert
 202                     (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id));
 203                   Snew.Instance := Inst_Spec_Inst_Id;
 204                end;
 205
 206             else
 207                Instances.Append (Sloc (Inst_Node));
 208                Snew.Instance := Instances.Last;
 209             end if;
 210          end if;
 211
 212          --  Now we need to compute the new values of Source_First,
 213          --  Source_Last and adjust the source file pointer to have the
 214          --  correct virtual origin for the new range of values.
 215
 216          Snew.Source_First := Source_File.Table (Xnew - 1).Source_Last + 1;
 217          A.Adjust := Snew.Source_First - A.Lo;
 218          Snew.Source_Last := A.Hi + A.Adjust;
 219
 220          Set_Source_File_Index_Table (Xnew);
 221
 222          Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust;
 223
 224          if Debug_Flag_L then
 225             Write_Eol;
 226             Write_Str ("*** Create instantiation source for ");
 227
 228             if Nkind (Dnod) in N_Proper_Body
 229               and then Was_Originally_Stub (Dnod)
 230             then
 231                Write_Str ("subunit ");
 232
 233             elsif Ekind (Template_Id) = E_Generic_Package then
 234                if Nkind (Dnod) = N_Package_Body then
 235                   Write_Str ("body of package ");
 236                else
 237                   Write_Str ("spec of package ");
 238                end if;
 239
 240             elsif Ekind (Template_Id) = E_Function then
 241                Write_Str ("body of function ");
 242
 243             elsif Ekind (Template_Id) = E_Procedure then
 244                Write_Str ("body of procedure ");
 245
 246             elsif Ekind (Template_Id) = E_Generic_Function then
 247                Write_Str ("spec of function ");
 248
 249             elsif Ekind (Template_Id) = E_Generic_Procedure then
 250                Write_Str ("spec of procedure ");
 251
 252             elsif Ekind (Template_Id) = E_Package_Body then
 253                Write_Str ("body of package ");
 254
 255             else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
 256
 257                if Nkind (Dnod) = N_Procedure_Specification then
 258                   Write_Str ("body of procedure ");
 259                else
 260                   Write_Str ("body of function ");
 261                end if;
 262             end if;
 263
 264             Write_Name (Chars (Template_Id));
 265             Write_Eol;
 266
 267             Write_Str ("  new source index = ");
 268             Write_Int (Int (Xnew));
 269             Write_Eol;
 270
 271             Write_Str ("  copying from file name = ");
 272             Write_Name (File_Name (Xold));
 273             Write_Eol;
 274
 275             Write_Str ("  old source index = ");
 276             Write_Int (Int (Xold));
 277             Write_Eol;
 278
 279             Write_Str ("  old lo = ");
 280             Write_Int (Int (A.Lo));
 281             Write_Eol;
 282
 283             Write_Str ("  old hi = ");
 284             Write_Int (Int (A.Hi));
 285             Write_Eol;
 286
 287             Write_Str ("  new lo = ");
 288             Write_Int (Int (Snew.Source_First));
 289             Write_Eol;
 290
 291             Write_Str ("  new hi = ");
 292             Write_Int (Int (Snew.Source_Last));
 293             Write_Eol;
 294
 295             Write_Str ("  adjustment factor = ");
 296             Write_Int (Int (A.Adjust));
 297             Write_Eol;
 298
 299             Write_Str ("  instantiation location: ");
 300             Write_Location (Sloc (Inst_Node));
 301             Write_Eol;
 302          end if;
 303
 304          --  For a given character in the source, a higher subscript will be
 305          --  used to access the instantiation, which means that the virtual
 306          --  origin must have a corresponding lower value. We compute this new
 307          --  origin by taking the address of the appropriate adjusted element
 308          --  in the old array. Since this adjusted element will be at a
 309          --  negative subscript, we must suppress checks.
 310
 311          declare
 312             pragma Suppress (All_Checks);
 313
 314             pragma Warnings (Off);
 315             --  This unchecked conversion is aliasing safe, since it is never
 316             --  used to create improperly aliased pointer values.
 317
 318             function To_Source_Buffer_Ptr is new
 319               Unchecked_Conversion (Address, Source_Buffer_Ptr);
 320
 321             pragma Warnings (On);
 322
 323          begin
 324             Snew.Source_Text :=
 325               To_Source_Buffer_Ptr
 326                 (Sold.Source_Text (-A.Adjust)'Address);
 327          end;
 328       end;
 329    end Create_Instantiation_Source;
 330
 331    ----------------------
 332    -- Load_Config_File --
 333    ----------------------
 334
 335    function Load_Config_File
 336      (N : File_Name_Type) return Source_File_Index
 337    is
 338    begin
 339       return Load_File (N, Osint.Config);
 340    end Load_Config_File;
 341
 342    --------------------------
 343    -- Load_Definition_File --
 344    --------------------------
 345
 346    function Load_Definition_File
 347      (N : File_Name_Type) return Source_File_Index
 348    is
 349    begin
 350       return Load_File (N, Osint.Definition);
 351    end Load_Definition_File;
 352
 353    ---------------
 354    -- Load_File --
 355    ---------------
 356
 357    function Load_File
 358      (N : File_Name_Type;
 359       T : Osint.File_Type) return Source_File_Index
 360    is
 361       Src : Source_Buffer_Ptr;
 362       X   : Source_File_Index;
 363       Lo  : Source_Ptr;
 364       Hi  : Source_Ptr;
 365
 366       Preprocessing_Needed : Boolean := False;
 367
 368    begin
 369       --  If already there, don't need to reload file. An exception occurs
 370       --  in multiple unit per file mode. It would be nice in this case to
 371       --  share the same source file for each unit, but this leads to many
 372       --  difficulties with assumptions (e.g. in the body of lib), that a
 373       --  unit can be found by locating its source file index. Since we do
 374       --  not expect much use of this mode, it's no big deal to waste a bit
 375       --  of space and time by reading and storing the source multiple times.
 376
 377       if Multiple_Unit_Index = 0 then
 378          for J in 1 .. Source_File.Last loop
 379             if Source_File.Table (J).File_Name = N then
 380                return J;
 381             end if;
 382          end loop;
 383       end if;
 384
 385       --  Here we must build a new entry in the file table
 386
 387       --  But first, we must check if a source needs to be preprocessed,
 388       --  because we may have to load and parse a definition file, and we want
 389       --  to do that before we load the source, so that the buffer of the
 390       --  source will be the last created, and we will be able to replace it
 391       --  and modify Hi without stepping on another buffer.
 392
 393       if T = Osint.Source and then not Is_Internal_File_Name (N) then
 394          Prepare_To_Preprocess
 395            (Source => N, Preprocessing_Needed => Preprocessing_Needed);
 396       end if;
 397
 398       Source_File.Increment_Last;
 399       X := Source_File.Last;
 400
 401       if X = Source_File.First then
 402          Lo := First_Source_Ptr;
 403       else
 404          Lo := Source_File.Table (X - 1).Source_Last + 1;
 405       end if;
 406
 407       Osint.Read_Source_File (N, Lo, Hi, Src, T);
 408
 409       if Src = null then
 410          Source_File.Decrement_Last;
 411          return No_Source_File;
 412
 413       else
 414          if Debug_Flag_L then
 415             Write_Eol;
 416             Write_Str ("*** Build source file table entry, Index = ");
 417             Write_Int (Int (X));
 418             Write_Str (", file name = ");
 419             Write_Name (N);
 420             Write_Eol;
 421             Write_Str ("  lo = ");
 422             Write_Int (Int (Lo));
 423             Write_Eol;
 424             Write_Str ("  hi = ");
 425             Write_Int (Int (Hi));
 426             Write_Eol;
 427
 428             Write_Str ("  first 10 chars -->");
 429
 430             declare
 431                procedure Wchar (C : Character);
 432                --  Writes character or ? for control character
 433
 434                -----------
 435                -- Wchar --
 436                -----------
 437
 438                procedure Wchar (C : Character) is
 439                begin
 440                   if C < ' '
 441                     or else C in ASCII.DEL .. Character'Val (16#9F#)
 442                   then
 443                      Write_Char ('?');
 444                   else
 445                      Write_Char (C);
 446                   end if;
 447                end Wchar;
 448
 449             begin
 450                for J in Lo .. Lo + 9 loop
 451                   Wchar (Src (J));
 452                end loop;
 453
 454                Write_Str ("<--");
 455                Write_Eol;
 456
 457                Write_Str ("  last 10 chars  -->");
 458
 459                for J in Hi - 10 .. Hi - 1 loop
 460                   Wchar (Src (J));
 461                end loop;
 462
 463                Write_Str ("<--");
 464                Write_Eol;
 465
 466                if Src (Hi) /= EOF then
 467                   Write_Str ("  error: no EOF at end");
 468                   Write_Eol;
 469                end if;
 470             end;
 471          end if;
 472
 473          declare
 474             S         : Source_File_Record renames Source_File.Table (X);
 475             File_Type : Type_Of_File;
 476
 477          begin
 478             case T is
 479                when Osint.Source =>
 480                   File_Type := Sinput.Src;
 481
 482                when Osint.Library =>
 483                   raise Program_Error;
 484
 485                when Osint.Config =>
 486                   File_Type := Sinput.Config;
 487
 488                when Osint.Definition =>
 489                   File_Type := Def;
 490
 491                when Osint.Preprocessing_Data =>
 492                   File_Type := Preproc;
 493             end case;
 494
 495             S := (Debug_Source_Name   => N,
 496                   File_Name           => N,
 497                   File_Type           => File_Type,
 498                   First_Mapped_Line   => No_Line_Number,
 499                   Full_Debug_Name     => Osint.Full_Source_Name,
 500                   Full_File_Name      => Osint.Full_Source_Name,
 501                   Full_Ref_Name       => Osint.Full_Source_Name,
 502                   Instance            => No_Instance_Id,
 503                   Identifier_Casing   => Unknown,
 504                   Inlined_Call        => No_Location,
 505                   Inlined_Body        => False,
 506                   Keyword_Casing      => Unknown,
 507                   Last_Source_Line    => 1,
 508                   License             => Unknown,
 509                   Lines_Table         => null,
 510                   Lines_Table_Max     => 1,
 511                   Logical_Lines_Table => null,
 512                   Num_SRef_Pragmas    => 0,
 513                   Reference_Name      => N,
 514                   Sloc_Adjust         => 0,
 515                   Source_Checksum     => 0,
 516                   Source_First        => Lo,
 517                   Source_Last         => Hi,
 518                   Source_Text         => Src,
 519                   Template            => No_Source_File,
 520                   Unit                => No_Unit,
 521                   Time_Stamp          => Osint.Current_Source_File_Stamp);
 522
 523             Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
 524             S.Lines_Table (1) := Lo;
 525          end;
 526
 527          --  Preprocess the source if it needs to be preprocessed
 528
 529          if Preprocessing_Needed then
 530
 531             --  Temporarily set the Source_File_Index_Table entries for the
 532             --  source, to avoid crash when reporting an error.
 533
 534             Set_Source_File_Index_Table (X);
 535
 536             if Opt.List_Preprocessing_Symbols then
 537                Get_Name_String (N);
 538
 539                declare
 540                   Foreword : String (1 .. Foreword_Start'Length +
 541                                           Name_Len + Foreword_End'Length);
 542
 543                begin
 544                   Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
 545                   Foreword (Foreword_Start'Length + 1 ..
 546                               Foreword_Start'Length + Name_Len) :=
 547                     Name_Buffer (1 .. Name_Len);
 548                   Foreword (Foreword'Last - Foreword_End'Length + 1 ..
 549                               Foreword'Last) := Foreword_End;
 550                   Prep.List_Symbols (Foreword);
 551                end;
 552             end if;
 553
 554             declare
 555                T : constant Nat := Total_Errors_Detected;
 556                --  Used to check if there were errors during preprocessing
 557
 558                Save_Style_Check : Boolean;
 559                --  Saved state of the Style_Check flag (which needs to be
 560                --  temporarily set to False during preprocessing, see below).
 561
 562                Modified : Boolean;
 563
 564             begin
 565                --  If this is the first time we preprocess a source, allocate
 566                --  the preprocessing buffer.
 567
 568                if Prep_Buffer = null then
 569                   Prep_Buffer :=
 570                     new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
 571                end if;
 572
 573                --  Make sure the preprocessing buffer is empty
 574
 575                Prep_Buffer_Last := 0;
 576
 577                --  Initialize the preprocessor hooks
 578
 579                Prep.Setup_Hooks
 580                  (Error_Msg         => Errout.Error_Msg'Access,
 581                   Scan              => Scn.Scanner.Scan'Access,
 582                   Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
 583                   Put_Char          => Put_Char_In_Prep_Buffer'Access,
 584                   New_EOL           => New_EOL_In_Prep_Buffer'Access);
 585
 586                --  Initialize scanner and set its behavior for preprocessing,
 587                --  then preprocess. Also disable style checks, since some of
 588                --  them are done in the scanner (specifically, those dealing
 589                --  with line length and line termination), and cannot be done
 590                --  during preprocessing (because the source file index table
 591                --  has not been set yet).
 592
 593                Scn.Scanner.Initialize_Scanner (X);
 594
 595                Scn.Scanner.Set_Special_Character ('#');
 596                Scn.Scanner.Set_Special_Character ('$');
 597                Scn.Scanner.Set_End_Of_Line_As_Token (True);
 598                Save_Style_Check := Opt.Style_Check;
 599                Opt.Style_Check := False;
 600
 601                --  The actual preprocessing step
 602
 603                Preprocess (Modified);
 604
 605                --  Reset the scanner to its standard behavior, and restore the
 606                --  Style_Checks flag.
 607
 608                Scn.Scanner.Reset_Special_Characters;
 609                Scn.Scanner.Set_End_Of_Line_As_Token (False);
 610                Opt.Style_Check := Save_Style_Check;
 611
 612                --  If there were errors during preprocessing, record an error
 613                --  at the start of the file, and do not change the source
 614                --  buffer.
 615
 616                if T /= Total_Errors_Detected then
 617                   Errout.Error_Msg
 618                     ("file could not be successfully preprocessed", Lo);
 619                   return No_Source_File;
 620
 621                else
 622                   --  Output the result of the preprocessing, if requested and
 623                   --  the source has been modified by the preprocessing. Only
 624                   --  do that for the main unit (spec, body and subunits).
 625
 626                   if Generate_Processed_File
 627                     and then Modified
 628                     and then
 629                      ((Compiler_State = Parsing
 630                         and then Parsing_Main_Extended_Source)
 631                        or else
 632                         (Compiler_State = Analyzing
 633                           and then Analysing_Subunit_Of_Main))
 634                   then
 635                      declare
 636                         FD     : File_Descriptor;
 637                         NB     : Integer;
 638                         Status : Boolean;
 639
 640                      begin
 641                         Get_Name_String (N);
 642
 643                         if Hostparm.OpenVMS then
 644                            Add_Str_To_Name_Buffer ("_prep");
 645                         else
 646                            Add_Str_To_Name_Buffer (".prep");
 647                         end if;
 648
 649                         Delete_File (Name_Buffer (1 .. Name_Len), Status);
 650
 651                         FD :=
 652                           Create_New_File (Name_Buffer (1 .. Name_Len), Text);
 653
 654                         Status := FD /= Invalid_FD;
 655
 656                         if Status then
 657                            NB :=
 658                              Write
 659                                (FD,
 660                                 Prep_Buffer (1)'Address,
 661                                 Integer (Prep_Buffer_Last));
 662                            Status := NB = Integer (Prep_Buffer_Last);
 663                         end if;
 664
 665                         if Status then
 666                            Close (FD, Status);
 667                         end if;
 668
 669                         if not Status then
 670                            Errout.Error_Msg
 671                              ("??could not write processed file """ &
 672                               Name_Buffer (1 .. Name_Len) & '"',
 673                               Lo);
 674                         end if;
 675                      end;
 676                   end if;
 677
 678                   --  Set the new value of Hi
 679
 680                   Hi := Lo + Source_Ptr (Prep_Buffer_Last);
 681
 682                   --  Create the new source buffer
 683
 684                   declare
 685                      subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
 686                      --  Physical buffer allocated
 687
 688                      type Actual_Source_Ptr is access Actual_Source_Buffer;
 689                      --  Pointer type for the physical buffer allocated
 690
 691                      Actual_Ptr : constant Actual_Source_Ptr :=
 692                                     new Actual_Source_Buffer;
 693                      --  Actual physical buffer
 694
 695                   begin
 696                      Actual_Ptr (Lo .. Hi - 1) :=
 697                        Prep_Buffer (1 .. Prep_Buffer_Last);
 698                      Actual_Ptr (Hi) := EOF;
 699
 700                      --  Now we need to work out the proper virtual origin
 701                      --  pointer to return. This is Actual_Ptr (0)'Address, but
 702                      --  we have to be careful to suppress checks to compute
 703                      --  this address.
 704
 705                      declare
 706                         pragma Suppress (All_Checks);
 707
 708                         pragma Warnings (Off);
 709                         --  This unchecked conversion is aliasing safe, since
 710                         --  it is never used to create improperly aliased
 711                         --  pointer values.
 712
 713                         function To_Source_Buffer_Ptr is new
 714                           Unchecked_Conversion (Address, Source_Buffer_Ptr);
 715
 716                         pragma Warnings (On);
 717
 718                      begin
 719                         Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
 720
 721                         --  Record in the table the new source buffer and the
 722                         --  new value of Hi.
 723
 724                         Source_File.Table (X).Source_Text := Src;
 725                         Source_File.Table (X).Source_Last := Hi;
 726
 727                         --  Reset Last_Line to 1, because the lines do not
 728                         --  have necessarily the same starts and lengths.
 729
 730                         Source_File.Table (X).Last_Source_Line := 1;
 731                      end;
 732                   end;
 733                end if;
 734             end;
 735          end if;
 736
 737          Set_Source_File_Index_Table (X);
 738          return X;
 739       end if;
 740    end Load_File;
 741
 742    ----------------------------------
 743    -- Load_Preprocessing_Data_File --
 744    ----------------------------------
 745
 746    function Load_Preprocessing_Data_File
 747      (N : File_Name_Type) return Source_File_Index
 748    is
 749    begin
 750       return Load_File (N, Osint.Preprocessing_Data);
 751    end Load_Preprocessing_Data_File;
 752
 753    ----------------------
 754    -- Load_Source_File --
 755    ----------------------
 756
 757    function Load_Source_File
 758      (N : File_Name_Type) return Source_File_Index
 759    is
 760    begin
 761       return Load_File (N, Osint.Source);
 762    end Load_Source_File;
 763
 764    ----------------------------
 765    -- New_EOL_In_Prep_Buffer --
 766    ----------------------------
 767
 768    procedure New_EOL_In_Prep_Buffer is
 769    begin
 770       Put_Char_In_Prep_Buffer (ASCII.LF);
 771    end New_EOL_In_Prep_Buffer;
 772
 773    -----------------------------
 774    -- Put_Char_In_Prep_Buffer --
 775    -----------------------------
 776
 777    procedure Put_Char_In_Prep_Buffer (C : Character) is
 778    begin
 779       --  If preprocessing buffer is not large enough, double it
 780
 781       if Prep_Buffer_Last = Prep_Buffer'Last then
 782          declare
 783             New_Prep_Buffer : constant Text_Buffer_Ptr :=
 784               new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
 785
 786          begin
 787             New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
 788             Free (Prep_Buffer);
 789             Prep_Buffer := New_Prep_Buffer;
 790          end;
 791       end if;
 792
 793       Prep_Buffer_Last := Prep_Buffer_Last + 1;
 794       Prep_Buffer (Prep_Buffer_Last) := C;
 795    end Put_Char_In_Prep_Buffer;
 796
 797    -----------------------------------
 798    -- Source_File_Is_Pragma_No_Body --
 799    -----------------------------------
 800
 801    function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
 802    begin
 803       Initialize_Scanner (No_Unit, X);
 804
 805       if Token /= Tok_Pragma then
 806          return False;
 807       end if;
 808
 809       Scan; -- past pragma
 810
 811       if Token /= Tok_Identifier
 812         or else Chars (Token_Node) /= Name_No_Body
 813       then
 814          return False;
 815       end if;
 816
 817       Scan; -- past No_Body
 818
 819       if Token /= Tok_Semicolon then
 820          return False;
 821       end if;
 822
 823       Scan; -- past semicolon
 824
 825       return Token = Tok_EOF;
 826    end Source_File_Is_No_Body;
 827
 828    ----------------------------
 829    -- Source_File_Is_Subunit --
 830    ----------------------------
 831
 832    function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
 833    begin
 834       Initialize_Scanner (No_Unit, X);
 835
 836       --  We scan past junk to the first interesting compilation unit token, to
 837       --  see if it is SEPARATE. We ignore WITH keywords during this and also
 838       --  PRIVATE. The reason for ignoring PRIVATE is that it handles some
 839       --  error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
 840
 841       while Token = Tok_With
 842         or else Token = Tok_Private
 843         or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
 844       loop
 845          Scan;
 846       end loop;
 847
 848       return Token = Tok_Separate;
 849    end Source_File_Is_Subunit;
 850
 851 end Sinput.L;