| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S I N P U T . L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2014, 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; |
| |
| 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; |
| |
| 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.Inlined_Body := Inlined_Body; |
| Snew.Template := Xold; |
| |
| -- For a genuine generic instantiation, assign new instance id. |
| -- For inlined bodies, we retain that of the template, but we |
| -- save the call location. |
| |
| if Inlined_Body 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 we need to compute the new values of Source_First and |
| -- Source_Last and adjust the source file pointer to have the |
| -- correct virtual origin 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; |
| A.Adjust := Snew.Source_First - A.Lo; |
| Snew.Source_Last := A.Hi + A.Adjust; |
| |
| Set_Source_File_Index_Table (Xnew); |
| |
| Snew.Sloc_Adjust := Sold.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 (Snew.Source_First)); |
| Write_Eol; |
| |
| Write_Str (" new hi = "); |
| Write_Int (Int (Snew.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 |
| Snew.Source_Text := |
| To_Source_Buffer_Ptr |
| (Sold.Source_Text (-A.Adjust)'Address); |
| end; |
| 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; |
| |
| -- 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, 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, |
| Instance => No_Instance_Id, |
| Identifier_Casing => Unknown, |
| Inlined_Call => No_Location, |
| Inlined_Body => 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); |
| |
| 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 |
| 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_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_With | Tok_Use => |
| |
| -- 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_Procedure | Tok_Function => |
| 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_Is | Tok_End => |
| 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; |
