8sa1-gcc/gcc/ada/sinput-l.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S I N P U T . L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2020, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Alloc;
with Atree;    use Atree;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Fname;    use Fname;
with Lib;      use Lib;
with Opt;      use Opt;
with Osint;    use Osint;
with Output;   use Output;
with Prep;     use Prep;
with Prepcomp; use Prepcomp;
with Scans;    use Scans;
with Scn;      use Scn;
with Sem_Aux;  use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with System;   use System;

with System.OS_Lib; use System.OS_Lib;

package body Sinput.L is

   Prep_Buffer : Text_Buffer_Ptr := null;
   --  A buffer to temporarily stored the result of preprocessing a source.
   --  It is only allocated if there is at least one source to preprocess.

   Prep_Buffer_Last : Text_Ptr := 0;
   --  Index of the last significant character in Prep_Buffer

   Initial_Size_Of_Prep_Buffer : constant := 10_000;
   --  Size of Prep_Buffer when it is first allocated

   --  When a file is to be preprocessed and the options to list symbols
   --  has been selected (switch -s), Prep.List_Symbols is called with a
   --  "foreword", a single line indicating what source the symbols apply to.
   --  The following two constant String are the start and the end of this
   --  foreword.

   Foreword_Start : constant String :=
                      "Preprocessing Symbols for source """;

   Foreword_End : constant String := """";

   -----------------
   -- Subprograms --
   -----------------

   procedure Put_Char_In_Prep_Buffer (C : Character);
   --  Add one character in Prep_Buffer, extending Prep_Buffer if need be.
   --  Used to initialize the preprocessor.

   procedure New_EOL_In_Prep_Buffer;
   --  Add an LF to Prep_Buffer (used to initialize the preprocessor)

   function Load_File
     (N : File_Name_Type;
      T : Osint.File_Type) return Source_File_Index;
   --  Load a source file, a configuration pragmas file or a definition file
   --  Coding also allows preprocessing file, but not a library file ???

   -------------------------------
   -- Adjust_Instantiation_Sloc --
   -------------------------------

   procedure Adjust_Instantiation_Sloc
     (N      : Node_Id;
      Factor : Sloc_Adjustment)
   is
      Loc : constant Source_Ptr := Sloc (N);

   begin
      --  We only do the adjustment if the value is between the appropriate low
      --  and high values. It is not clear that this should ever not be the
      --  case, but in practice there seem to be some nodes that get copied
      --  twice, and this is a defence against that happening.

      if Loc in Factor.Lo .. Factor.Hi then
         Set_Sloc (N, Loc + Factor.Adjust);
      end if;
   end Adjust_Instantiation_Sloc;

   --------------------------------
   -- Complete_Source_File_Entry --
   --------------------------------

   procedure Complete_Source_File_Entry is
      CSF : constant Source_File_Index := Current_Source_File;
   begin
      Trim_Lines_Table (CSF);
      Source_File.Table (CSF).Source_Checksum := Checksum;
   end Complete_Source_File_Entry;

   ---------------------------------
   -- Create_Instantiation_Source --
   ---------------------------------

   procedure Create_Instantiation_Source
     (Inst_Node        : Entity_Id;
      Template_Id      : Entity_Id;
      Factor           : out Sloc_Adjustment;
      Inlined_Body     : Boolean := False;
      Inherited_Pragma : Boolean := False)
   is
      Dnod : constant Node_Id := Declaration_Node (Template_Id);
      Xold : Source_File_Index;
      Xnew : Source_File_Index;

   begin
      Xold      := Get_Source_File_Index (Sloc (Template_Id));
      Factor.Lo := Source_File.Table (Xold).Source_First;
      Factor.Hi := Source_File.Table (Xold).Source_Last;

      Source_File.Append (Source_File.Table (Xold));
      Xnew := Source_File.Last;

      if Debug_Flag_L then
         Write_Eol;
         Write_Str ("*** Create_Instantiation_Source: created source ");
         Write_Int (Int (Xnew));
         Write_Line ("");
      end if;

      declare
         Sold : Source_File_Record renames Source_File.Table (Xold);
         Snew : Source_File_Record renames Source_File.Table (Xnew);

         Inst_Spec : Node_Id;

      begin
         Snew.Index            := Xnew;
         Snew.Inlined_Body     := Inlined_Body;
         Snew.Inherited_Pragma := Inherited_Pragma;
         Snew.Template         := Xold;

         --  For a genuine generic instantiation, assign new instance id. For
         --  inlined bodies or inherited pragmas, we retain that of the
         --  template, but we save the call location.

         if Inlined_Body or Inherited_Pragma then
            Snew.Inlined_Call := Sloc (Inst_Node);

         else
            --  If the spec has been instantiated already, and we are now
            --  creating the instance source for the corresponding body now,
            --  retrieve the instance id that was assigned to the spec, which
            --  corresponds to the same instantiation sloc.

            Inst_Spec := Instance_Spec (Inst_Node);
            if Present (Inst_Spec) then
               declare
                  Inst_Spec_Ent : Entity_Id;
                  --  Instance spec entity

                  Inst_Spec_Sloc : Source_Ptr;
                  --  Virtual sloc of the spec instance source

                  Inst_Spec_Inst_Id : Instance_Id;
                  --  Instance id assigned to the instance spec

               begin
                  Inst_Spec_Ent := Defining_Entity (Inst_Spec);

                  --  For a subprogram instantiation, we want the subprogram
                  --  instance, not the wrapper package.

                  if Present (Related_Instance (Inst_Spec_Ent)) then
                     Inst_Spec_Ent := Related_Instance (Inst_Spec_Ent);
                  end if;

                  --  The specification of the instance entity has a virtual
                  --  sloc within the instance sloc range.

                  --  ??? But the Unit_Declaration_Node has the sloc of the
                  --  instantiation, which is somewhat of an oddity.

                  Inst_Spec_Sloc :=
                    Sloc
                      (Specification (Unit_Declaration_Node (Inst_Spec_Ent)));
                  Inst_Spec_Inst_Id :=
                    Source_File.Table
                      (Get_Source_File_Index (Inst_Spec_Sloc)).Instance;

                  pragma Assert
                    (Sloc (Inst_Node) = Instances.Table (Inst_Spec_Inst_Id));
                  Snew.Instance := Inst_Spec_Inst_Id;
               end;

            else
               Instances.Append (Sloc (Inst_Node));
               Snew.Instance := Instances.Last;
            end if;
         end if;

         --  Now compute the new values of Source_First and Source_Last and
         --  adjust the source file pointer to have the correct bounds for the
         --  new range of values.

         --  Source_First must be greater than the last Source_Last value and
         --  also must be a multiple of Source_Align.

         Snew.Source_First :=
           ((Source_File.Table (Xnew - 1).Source_Last + Source_Align) /
              Source_Align) * Source_Align;
         Factor.Adjust := Snew.Source_First - Factor.Lo;
         Snew.Source_Last := Factor.Hi + Factor.Adjust;

         Set_Source_File_Index_Table (Xnew);

         Snew.Sloc_Adjust := Sold.Sloc_Adjust - Factor.Adjust;

         --  Modify the Dope of the instance Source_Text to use the
         --  above-computed bounds.

         declare
            Dope : constant Dope_Ptr :=
              new Dope_Rec'(Snew.Source_First, Snew.Source_Last);
         begin
            Snew.Source_Text := Sold.Source_Text;
            Set_Dope (Snew.Source_Text'Address, Dope);
            pragma Assert (Snew.Source_Text'First = Snew.Source_First);
            pragma Assert (Snew.Source_Text'Last = Snew.Source_Last);
         end;

         if Debug_Flag_L then
            Write_Str ("  for ");

            if Nkind (Dnod) in N_Proper_Body
              and then Was_Originally_Stub (Dnod)
            then
               Write_Str ("subunit ");

            elsif Ekind (Template_Id) = E_Generic_Package then
               if Nkind (Dnod) = N_Package_Body then
                  Write_Str ("body of package ");
               else
                  Write_Str ("spec of package ");
               end if;

            elsif Ekind (Template_Id) = E_Function then
               Write_Str ("body of function ");

            elsif Ekind (Template_Id) = E_Procedure then
               Write_Str ("body of procedure ");

            elsif Ekind (Template_Id) = E_Generic_Function then
               Write_Str ("spec of function ");

            elsif Ekind (Template_Id) = E_Generic_Procedure then
               Write_Str ("spec of procedure ");

            elsif Ekind (Template_Id) = E_Package_Body then
               Write_Str ("body of package ");

            else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
               if Nkind (Dnod) = N_Procedure_Specification then
                  Write_Str ("body of procedure ");
               else
                  Write_Str ("body of function ");
               end if;
            end if;

            Write_Name (Chars (Template_Id));
            Write_Eol;

            Write_Str ("  copying from file name = ");
            Write_Name (File_Name (Xold));
            Write_Eol;

            Write_Str ("  old source index = ");
            Write_Int (Int (Xold));
            Write_Eol;

            Write_Str ("  old lo = ");
            Write_Int (Int (Factor.Lo));
            Write_Eol;

            Write_Str ("  old hi = ");
            Write_Int (Int (Factor.Hi));
            Write_Eol;

            Write_Str ("  new lo = ");
            Write_Int (Int (Snew.Source_First));
            Write_Eol;

            Write_Str ("  new hi = ");
            Write_Int (Int (Snew.Source_Last));
            Write_Eol;

            Write_Str ("  adjustment factor = ");
            Write_Int (Int (Factor.Adjust));
            Write_Eol;

            Write_Str ("  instantiation location: ");
            Write_Location (Sloc (Inst_Node));
            Write_Eol;
         end if;
      end;
   end Create_Instantiation_Source;

   ----------------------
   -- Load_Config_File --
   ----------------------

   function Load_Config_File
     (N : File_Name_Type) return Source_File_Index
   is
   begin
      return Load_File (N, Osint.Config);
   end Load_Config_File;

   --------------------------
   -- Load_Definition_File --
   --------------------------

   function Load_Definition_File
     (N : File_Name_Type) return Source_File_Index
   is
   begin
      return Load_File (N, Osint.Definition);
   end Load_Definition_File;

   ---------------
   -- Load_File --
   ---------------

   function Load_File
     (N : File_Name_Type;
      T : Osint.File_Type) return Source_File_Index
   is
      FD  : File_Descriptor;
      Hi  : Source_Ptr;
      Lo  : Source_Ptr;
      Src : Source_Buffer_Ptr;
      X   : Source_File_Index;

      Preprocessing_Needed : Boolean := False;

   begin
      --  If already there, don't need to reload file. An exception occurs
      --  in multiple unit per file mode. It would be nice in this case to
      --  share the same source file for each unit, but this leads to many
      --  difficulties with assumptions (e.g. in the body of lib), that a
      --  unit can be found by locating its source file index. Since we do
      --  not expect much use of this mode, it's no big deal to waste a bit
      --  of space and time by reading and storing the source multiple times.

      if Multiple_Unit_Index = 0 then
         for J in 1 .. Source_File.Last loop
            if Source_File.Table (J).File_Name = N then
               return J;
            end if;
         end loop;
      end if;

      --  Here we must build a new entry in the file table

      --  But first, we must check if a source needs to be preprocessed,
      --  because we may have to load and parse a definition file, and we want
      --  to do that before we load the source, so that the buffer of the
      --  source will be the last created, and we will be able to replace it
      --  and modify Hi without stepping on another buffer.

      if T = Osint.Source and then not Is_Internal_File_Name (N) then
         Prepare_To_Preprocess
           (Source => N, Preprocessing_Needed => Preprocessing_Needed);
      end if;

      Source_File.Increment_Last;
      X := Source_File.Last;

      if Debug_Flag_L then
         Write_Eol;
         Write_Str ("Sinput.L.Load_File: created source ");
         Write_Int (Int (X));
         Write_Str (" for ");
         Write_Str (Get_Name_String (N));
      end if;

      --  Compute starting index, respecting alignment requirement

      if X = Source_File.First then
         Lo := First_Source_Ptr;
      else
         Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) /
                  Source_Align) * Source_Align;
      end if;

      Osint.Read_Source_File (N, Lo, Hi, Src, FD, T);

      if Null_Source_Buffer_Ptr (Src) then
         Source_File.Decrement_Last;

         if FD = Null_FD then
            return No_Source_File;
         else
            return No_Access_To_Source_File;
         end if;
      else
         if Debug_Flag_L then
            Write_Eol;
            Write_Str ("*** Build source file table entry, Index = ");
            Write_Int (Int (X));
            Write_Str (", file name = ");
            Write_Name (N);
            Write_Eol;
            Write_Str ("  lo = ");
            Write_Int (Int (Lo));
            Write_Eol;
            Write_Str ("  hi = ");
            Write_Int (Int (Hi));
            Write_Eol;

            Write_Str ("  first 10 chars -->");

            declare
               procedure Wchar (C : Character);
               --  Writes character or ? for control character

               -----------
               -- Wchar --
               -----------

               procedure Wchar (C : Character) is
               begin
                  if C < ' '
                    or else C in ASCII.DEL .. Character'Val (16#9F#)
                  then
                     Write_Char ('?');
                  else
                     Write_Char (C);
                  end if;
               end Wchar;

            begin
               for J in Lo .. Lo + 9 loop
                  Wchar (Src (J));
               end loop;

               Write_Str ("<--");
               Write_Eol;

               Write_Str ("  last 10 chars  -->");

               for J in Hi - 10 .. Hi - 1 loop
                  Wchar (Src (J));
               end loop;

               Write_Str ("<--");
               Write_Eol;

               if Src (Hi) /= EOF then
                  Write_Str ("  error: no EOF at end");
                  Write_Eol;
               end if;
            end;
         end if;

         declare
            S         : Source_File_Record renames Source_File.Table (X);
            File_Type : Type_Of_File;

         begin
            case T is
               when Osint.Source =>
                  File_Type := Sinput.Src;

               when Osint.Library =>
                  raise Program_Error;

               when Osint.Config =>
                  File_Type := Sinput.Config;

               when Osint.Definition =>
                  File_Type := Def;

               when Osint.Preprocessing_Data =>
                  File_Type := Preproc;
            end case;

            S := (Debug_Source_Name   => N,
                  File_Name           => N,
                  File_Type           => File_Type,
                  First_Mapped_Line   => No_Line_Number,
                  Full_Debug_Name     => Osint.Full_Source_Name,
                  Full_File_Name      => Osint.Full_Source_Name,
                  Full_Ref_Name       => Osint.Full_Source_Name,
                  Instance            => No_Instance_Id,
                  Identifier_Casing   => Unknown,
                  Inlined_Call        => No_Location,
                  Inlined_Body        => False,
                  Inherited_Pragma    => False,
                  Keyword_Casing      => Unknown,
                  Last_Source_Line    => 1,
                  License             => Unknown,
                  Lines_Table         => null,
                  Lines_Table_Max     => 1,
                  Logical_Lines_Table => null,
                  Num_SRef_Pragmas    => 0,
                  Reference_Name      => N,
                  Sloc_Adjust         => 0,
                  Source_Checksum     => 0,
                  Source_First        => Lo,
                  Source_Last         => Hi,
                  Source_Text         => Src,
                  Template            => No_Source_File,
                  Unit                => No_Unit,
                  Time_Stamp          => Osint.Current_Source_File_Stamp,
                  Index               => X);

            Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
            S.Lines_Table (1) := Lo;
         end;

         --  Preprocess the source if it needs to be preprocessed

         if Preprocessing_Needed then

            --  Temporarily set the Source_File_Index_Table entries for the
            --  source, to avoid crash when reporting an error.

            Set_Source_File_Index_Table (X);

            if Opt.List_Preprocessing_Symbols then
               Get_Name_String (N);

               declare
                  Foreword : String (1 .. Foreword_Start'Length +
                                          Name_Len + Foreword_End'Length);

               begin
                  Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
                  Foreword (Foreword_Start'Length + 1 ..
                              Foreword_Start'Length + Name_Len) :=
                    Name_Buffer (1 .. Name_Len);
                  Foreword (Foreword'Last - Foreword_End'Length + 1 ..
                              Foreword'Last) := Foreword_End;
                  Prep.List_Symbols (Foreword);
               end;
            end if;

            declare
               T : constant Nat := Total_Errors_Detected;
               --  Used to check if there were errors during preprocessing

               Save_Style_Check : Boolean;
               --  Saved state of the Style_Check flag (which needs to be
               --  temporarily set to False during preprocessing, see below).

               Modified : Boolean;

            begin
               --  If this is the first time we preprocess a source, allocate
               --  the preprocessing buffer.

               if Prep_Buffer = null then
                  Prep_Buffer :=
                    new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
               end if;

               --  Make sure the preprocessing buffer is empty

               Prep_Buffer_Last := 0;

               --  Initialize the preprocessor hooks

               Prep.Setup_Hooks
                 (Error_Msg         => Errout.Error_Msg'Access,
                  Scan              => Scn.Scanner.Scan'Access,
                  Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
                  Put_Char          => Put_Char_In_Prep_Buffer'Access,
                  New_EOL           => New_EOL_In_Prep_Buffer'Access);

               --  Initialize scanner and set its behavior for preprocessing,
               --  then preprocess. Also disable style checks, since some of
               --  them are done in the scanner (specifically, those dealing
               --  with line length and line termination), and cannot be done
               --  during preprocessing (because the source file index table
               --  has not been set yet).

               Scn.Scanner.Initialize_Scanner (X);

               Scn.Scanner.Set_Special_Character ('#');
               Scn.Scanner.Set_Special_Character ('$');
               Scn.Scanner.Set_End_Of_Line_As_Token (True);
               Save_Style_Check := Opt.Style_Check;
               Opt.Style_Check := False;

               --  The actual preprocessing step

               Preprocess (Modified);

               --  Reset the scanner to its standard behavior, and restore the
               --  Style_Checks flag.

               Scn.Scanner.Reset_Special_Characters;
               Scn.Scanner.Set_End_Of_Line_As_Token (False);
               Opt.Style_Check := Save_Style_Check;

               --  If there were errors during preprocessing, record an error
               --  at the start of the file, and do not change the source
               --  buffer.

               if T /= Total_Errors_Detected then
                  Errout.Error_Msg
                    ("file could not be successfully preprocessed", Lo);
                  return No_Source_File;

               else
                  --  Output the result of the preprocessing, if requested and
                  --  the source has been modified by the preprocessing. Only
                  --  do that for the main unit (spec, body and subunits).

                  if Generate_Processed_File
                    and then Modified
                    and then
                     ((Compiler_State = Parsing
                        and then Parsing_Main_Extended_Source)
                       or else
                        (Compiler_State = Analyzing
                          and then Analysing_Subunit_Of_Main))
                  then
                     declare
                        FD     : File_Descriptor;
                        NB     : Integer;
                        Status : Boolean;

                     begin
                        Get_Name_String (N);
                        Add_Str_To_Name_Buffer (Prep_Suffix);

                        Delete_File (Name_Buffer (1 .. Name_Len), Status);

                        FD :=
                          Create_New_File (Name_Buffer (1 .. Name_Len), Text);

                        Status := FD /= Invalid_FD;

                        if Status then
                           NB :=
                             Write
                               (FD,
                                Prep_Buffer (1)'Address,
                                Integer (Prep_Buffer_Last));
                           Status := NB = Integer (Prep_Buffer_Last);
                        end if;

                        if Status then
                           Close (FD, Status);
                        end if;

                        if not Status then
                           Errout.Error_Msg
                             ("??could not write processed file """ &
                              Name_Buffer (1 .. Name_Len) & '"',
                              Lo);
                        end if;
                     end;
                  end if;

                  --  Set the new value of Hi

                  Hi := Lo + Source_Ptr (Prep_Buffer_Last);

                  --  Create the new source buffer

                  declare
                     Var_Ptr : constant Source_Buffer_Ptr_Var :=
                       new Source_Buffer (Lo .. Hi);
                     --  Allocate source buffer, allowing extra character at
                     --  end for EOF.

                  begin
                     Var_Ptr (Lo .. Hi - 1) :=
                       Prep_Buffer (1 .. Prep_Buffer_Last);
                     Var_Ptr (Hi) := EOF;
                     Src := Var_Ptr.all'Access;
                  end;

                  --  Record in the table the new source buffer and the
                  --  new value of Hi.

                  Source_File.Table (X).Source_Text := Src;
                  Source_File.Table (X).Source_Last := Hi;

                  --  Reset Last_Line to 1, because the lines do not
                  --  have necessarily the same starts and lengths.

                  Source_File.Table (X).Last_Source_Line := 1;
               end if;
            end;
         end if;

         Set_Source_File_Index_Table (X);
         return X;
      end if;
   end Load_File;

   ----------------------------------
   -- Load_Preprocessing_Data_File --
   ----------------------------------

   function Load_Preprocessing_Data_File
     (N : File_Name_Type) return Source_File_Index
   is
   begin
      return Load_File (N, Osint.Preprocessing_Data);
   end Load_Preprocessing_Data_File;

   ----------------------
   -- Load_Source_File --
   ----------------------

   function Load_Source_File
     (N : File_Name_Type) return Source_File_Index
   is
   begin
      return Load_File (N, Osint.Source);
   end Load_Source_File;

   ----------------------------
   -- New_EOL_In_Prep_Buffer --
   ----------------------------

   procedure New_EOL_In_Prep_Buffer is
   begin
      Put_Char_In_Prep_Buffer (ASCII.LF);
   end New_EOL_In_Prep_Buffer;

   -----------------------------
   -- Put_Char_In_Prep_Buffer --
   -----------------------------

   procedure Put_Char_In_Prep_Buffer (C : Character) is
   begin
      --  If preprocessing buffer is not large enough, double it

      if Prep_Buffer_Last = Prep_Buffer'Last then
         declare
            New_Prep_Buffer : constant Text_Buffer_Ptr :=
              new Text_Buffer (1 .. 2 * Prep_Buffer_Last);

         begin
            New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
            Free (Prep_Buffer);
            Prep_Buffer := New_Prep_Buffer;
         end;
      end if;

      Prep_Buffer_Last := Prep_Buffer_Last + 1;
      Prep_Buffer (Prep_Buffer_Last) := C;
   end Put_Char_In_Prep_Buffer;

   -------------------------
   -- Source_File_Is_Body --
   -------------------------

   function Source_File_Is_Body (X : Source_File_Index) return Boolean is
      Pcount : Natural;

   begin
      Initialize_Scanner (No_Unit, X);

      --  Loop to look for subprogram or package body

      loop
         case Token is

            --  PRAGMA, WITH, USE (which can appear before a body)

            when Tok_Pragma
               | Tok_Use
               | Tok_With
            =>
               --  We just want to skip any of these, do it by skipping to a
               --  semicolon, but check for EOF, in case we have bad syntax.

               loop
                  if Token = Tok_Semicolon then
                     Scan;
                     exit;
                  elsif Token = Tok_EOF then
                     return False;
                  else
                     Scan;
                  end if;
               end loop;

            --  PACKAGE

            when Tok_Package =>
               Scan; -- Past PACKAGE

               --  We have a body if and only if BODY follows

               return Token = Tok_Body;

            --  FUNCTION or PROCEDURE

            when Tok_Function
               | Tok_Procedure
            =>
               Pcount := 0;

               --  Loop through tokens following PROCEDURE or FUNCTION

               loop
                  Scan;

                  case Token is

                     --  For parens, count paren level (note that paren level
                     --  can get greater than 1 if we have default parameters).

                     when Tok_Left_Paren =>
                        Pcount := Pcount + 1;

                     when Tok_Right_Paren =>
                        Pcount := Pcount - 1;

                     --  EOF means something weird, probably no body

                     when Tok_EOF =>
                        return False;

                     --  BEGIN or IS or END definitely means body is present

                     when Tok_Begin
                        | Tok_End
                        | Tok_Is
                     =>
                        return True;

                     --  Semicolon means no body present if at outside any
                     --  parens. If within parens, ignore, since it could be
                     --  a parameter separator.

                     when Tok_Semicolon =>
                        if Pcount = 0 then
                           return False;
                        end if;

                     --  Skip anything else

                     when others =>
                        null;
                  end case;
               end loop;

            --  Anything else in main scan means we don't have a body

            when others =>
               return False;
         end case;
      end loop;
   end Source_File_Is_Body;

   ----------------------------
   -- Source_File_Is_No_Body --
   ----------------------------

   function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
   begin
      Initialize_Scanner (No_Unit, X);

      if Token /= Tok_Pragma then
         return False;
      end if;

      Scan; -- past pragma

      if Token /= Tok_Identifier
        or else Chars (Token_Node) /= Name_No_Body
      then
         return False;
      end if;

      Scan; -- past No_Body

      if Token /= Tok_Semicolon then
         return False;
      end if;

      Scan; -- past semicolon

      return Token = Tok_EOF;
   end Source_File_Is_No_Body;

end Sinput.L;