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