aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/sinput-l.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/sinput-l.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/sinput-l.adb707
1 files changed, 707 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/sinput-l.adb b/gcc-4.3.1/gcc/ada/sinput-l.adb
new file mode 100644
index 000000000..79ad7f404
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/sinput-l.adb
@@ -0,0 +1,707 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2007, 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 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 Sinfo; use Sinfo;
+with Snames; use Snames;
+with System; use System;
+
+with Unchecked_Conversion;
+
+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 indicationg 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; A : 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 A.Lo <= Loc and then Loc <= A.Hi then
+ Set_Sloc (N, Loc + A.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;
+ Inlined_Body : Boolean;
+ A : out Sloc_Adjustment)
+ 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));
+ A.Lo := Source_File.Table (Xold).Source_First;
+ A.Hi := Source_File.Table (Xold).Source_Last;
+
+ Source_File.Append (Source_File.Table (Xold));
+ Xnew := Source_File.Last;
+
+ Source_File.Table (Xnew).Inlined_Body := Inlined_Body;
+ Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
+ Source_File.Table (Xnew).Template := Xold;
+
+ -- Now we need to compute the new values of Source_First, Source_Last
+ -- and adjust the source file pointer to have the correct virtual
+ -- origin for the new range of values.
+
+ Source_File.Table (Xnew).Source_First :=
+ Source_File.Table (Xnew - 1).Source_Last + 1;
+ A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
+ Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+
+ Set_Source_File_Index_Table (Xnew);
+
+ Source_File.Table (Xnew).Sloc_Adjust :=
+ Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
+
+ if Debug_Flag_L then
+ Write_Eol;
+ Write_Str ("*** Create instantiation source 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 (" new source index = ");
+ Write_Int (Int (Xnew));
+ 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 (A.Lo));
+ Write_Eol;
+
+ Write_Str (" old hi = ");
+ Write_Int (Int (A.Hi));
+ Write_Eol;
+
+ Write_Str (" new lo = ");
+ Write_Int (Int (Source_File.Table (Xnew).Source_First));
+ Write_Eol;
+
+ Write_Str (" new hi = ");
+ Write_Int (Int (Source_File.Table (Xnew).Source_Last));
+ Write_Eol;
+
+ Write_Str (" adjustment factor = ");
+ Write_Int (Int (A.Adjust));
+ Write_Eol;
+
+ Write_Str (" instantiation location: ");
+ Write_Location (Sloc (Inst_Node));
+ Write_Eol;
+ end if;
+
+ -- For a given character in the source, a higher subscript will be used
+ -- to access the instantiation, which means that the virtual origin must
+ -- have a corresponding lower value. We compute this new origin by
+ -- taking the address of the appropriate adjusted element in the old
+ -- array. Since this adjusted element will be at a negative subscript,
+ -- we must suppress checks.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since it is never used
+ -- to create improperly aliased pointer values.
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ pragma Warnings (On);
+
+ begin
+ Source_File.Table (Xnew).Source_Text :=
+ To_Source_Buffer_Ptr
+ (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
+ 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
+ Src : Source_Buffer_Ptr;
+ X : Source_File_Index;
+ Lo : Source_Ptr;
+ Hi : Source_Ptr;
+
+ 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 then
+ Prepare_To_Preprocess
+ (Source => N, Preprocessing_Needed => Preprocessing_Needed);
+ end if;
+
+ Source_File.Increment_Last;
+ X := Source_File.Last;
+
+ if X = Source_File.First then
+ Lo := First_Source_Ptr;
+ else
+ Lo := Source_File.Table (X - 1).Source_Last + 1;
+ end if;
+
+ Osint.Read_Source_File (N, Lo, Hi, Src, T);
+
+ if Src = null then
+ Source_File.Decrement_Last;
+ return No_Source_File;
+
+ 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
+
+ procedure Wchar (C : Character) is
+ begin
+ if C < ' ' or 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,
+ Identifier_Casing => Unknown,
+ Inlined_Body => False,
+ Instantiation => No_Location,
+ 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);
+
+ 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
+ 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).
+
+ 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
+
+ Prep.Initialize
+ (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;
+
+ Preprocess;
+
+ -- 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
+ -- Set the new value of Hi
+
+ Hi := Lo + Source_Ptr (Prep_Buffer_Last);
+
+ -- Create the new source buffer
+
+ declare
+ subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+ -- Physical buffer allocated
+
+ type Actual_Source_Ptr is access Actual_Source_Buffer;
+ -- Pointer type for the physical buffer allocated
+
+ Actual_Ptr : constant Actual_Source_Ptr :=
+ new Actual_Source_Buffer;
+ -- Actual physical buffer
+
+ begin
+ Actual_Ptr (Lo .. Hi - 1) :=
+ Prep_Buffer (1 .. Prep_Buffer_Last);
+ Actual_Ptr (Hi) := EOF;
+
+ -- Now we need to work out the proper virtual origin
+ -- pointer to return. This is Actual_Ptr (0)'Address, but
+ -- we have to be careful to suppress checks to compute
+ -- this address.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ pragma Warnings (Off);
+ -- This unchecked conversion is aliasing safe, since
+ -- it is never used to create improperly aliased
+ -- pointer values.
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ pragma Warnings (On);
+
+ begin
+ Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+
+ -- 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 neccessarily the same starts and lengths.
+
+ Source_File.Table (X).Last_Source_Line := 1;
+ end;
+ end;
+ 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_Pragma_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;
+
+ ----------------------------
+ -- Source_File_Is_Subunit --
+ ----------------------------
+
+ function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
+ begin
+ Initialize_Scanner (No_Unit, X);
+
+ -- We scan past junk to the first interesting compilation unit token, to
+ -- see if it is SEPARATE. We ignore WITH keywords during this and also
+ -- PRIVATE. The reason for ignoring PRIVATE is that it handles some
+ -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
+
+ while Token = Tok_With
+ or else Token = Tok_Private
+ or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
+ loop
+ Scan;
+ end loop;
+
+ return Token = Tok_Separate;
+ end Source_File_Is_Subunit;
+
+end Sinput.L;