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