URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sinput-l.adb] - Rev 706
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N P U T . L -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2010, 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 Hostparm; 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 Sinfo; use Sinfo; with Snames; use Snames; with System; use System; with System.OS_Lib; use System.OS_Lib; 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 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; 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 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 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 ----------- -- 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, 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 -- 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); if Hostparm.OpenVMS then Add_Str_To_Name_Buffer ("_prep"); else Add_Str_To_Name_Buffer (".prep"); end if; 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 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 necessarily 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;