+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S I N P U T --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Style_Checks (All_Checks);
--- Subprograms not all in alpha order
-
-with Debug; use Debug;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Tree_IO; use Tree_IO;
-with System; use System;
-
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
-
-package body Sinput is
-
- use ASCII;
- -- Make control characters visible
-
- First_Time_Around : Boolean := True;
-
- ---------------------------
- -- Add_Line_Tables_Entry --
- ---------------------------
-
- procedure Add_Line_Tables_Entry
- (S : in out Source_File_Record;
- P : Source_Ptr)
- is
- LL : Physical_Line_Number;
-
- begin
- -- Reallocate the lines tables if necessary.
-
- -- Note: the reason we do not use the normal Table package
- -- mechanism is that we have several of these tables. We could
- -- use the new GNAT.Dynamic_Tables package and that would probably
- -- be a good idea ???
-
- if S.Last_Source_Line = S.Lines_Table_Max then
- Alloc_Line_Tables
- (S,
- Int (S.Last_Source_Line) *
- ((100 + Alloc.Lines_Increment) / 100));
-
- if Debug_Flag_D then
- Write_Str ("--> Reallocating lines table, size = ");
- Write_Int (Int (S.Lines_Table_Max));
- Write_Eol;
- end if;
- end if;
-
- S.Last_Source_Line := S.Last_Source_Line + 1;
- LL := S.Last_Source_Line;
-
- S.Lines_Table (LL) := P;
-
- -- Deal with setting new entry in logical lines table if one is
- -- present. Note that there is always space (because the call to
- -- Alloc_Line_Tables makes sure both tables are the same length),
-
- if S.Logical_Lines_Table /= null then
-
- -- We can always set the entry from the previous one, because
- -- the processing for a Source_Reference pragma ensures that
- -- at least one entry following the pragma is set up correctly.
-
- S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
- end if;
- end Add_Line_Tables_Entry;
-
- -----------------------
- -- Alloc_Line_Tables --
- -----------------------
-
- procedure Alloc_Line_Tables
- (S : in out Source_File_Record;
- New_Max : Nat)
- is
- function realloc
- (memblock : Lines_Table_Ptr;
- size : size_t)
- return Lines_Table_Ptr;
- pragma Import (C, realloc, "realloc");
-
- function reallocl
- (memblock : Logical_Lines_Table_Ptr;
- size : size_t)
- return Logical_Lines_Table_Ptr;
- pragma Import (C, reallocl, "realloc");
-
- function malloc
- (size : size_t)
- return Lines_Table_Ptr;
- pragma Import (C, malloc, "malloc");
-
- function mallocl
- (size : size_t)
- return Logical_Lines_Table_Ptr;
- pragma Import (C, mallocl, "malloc");
-
- New_Table : Lines_Table_Ptr;
-
- New_Logical_Table : Logical_Lines_Table_Ptr;
-
- New_Size : constant size_t :=
- size_t (New_Max * Lines_Table_Type'Component_Size /
- Storage_Unit);
-
- begin
- if S.Lines_Table = null then
- New_Table := malloc (New_Size);
-
- else
- New_Table :=
- realloc (memblock => S.Lines_Table, size => New_Size);
- end if;
-
- if New_Table = null then
- raise Storage_Error;
- else
- S.Lines_Table := New_Table;
- S.Lines_Table_Max := Physical_Line_Number (New_Max);
- end if;
-
- if S.Num_SRef_Pragmas /= 0 then
- if S.Logical_Lines_Table = null then
- New_Logical_Table := mallocl (New_Size);
- else
- New_Logical_Table :=
- reallocl (memblock => S.Logical_Lines_Table, size => New_Size);
- end if;
-
- if New_Logical_Table = null then
- raise Storage_Error;
- else
- S.Logical_Lines_Table := New_Logical_Table;
- end if;
- end if;
- end Alloc_Line_Tables;
-
- -----------------
- -- Backup_Line --
- -----------------
-
- procedure Backup_Line (P : in out Source_Ptr) is
- Sindex : constant Source_File_Index := Get_Source_File_Index (P);
- Src : constant Source_Buffer_Ptr :=
- Source_File.Table (Sindex).Source_Text;
- Sfirst : constant Source_Ptr :=
- Source_File.Table (Sindex).Source_First;
-
- begin
- P := P - 1;
-
- if P = Sfirst then
- return;
- end if;
-
- if Src (P) = CR then
- if Src (P - 1) = LF then
- P := P - 1;
- end if;
-
- else -- Src (P) = LF
- if Src (P - 1) = CR then
- P := P - 1;
- end if;
- end if;
-
- -- Now find first character of the previous line
-
- while P > Sfirst
- and then Src (P - 1) /= LF
- and then Src (P - 1) /= CR
- loop
- P := P - 1;
- end loop;
- end Backup_Line;
-
- ---------------------------
- -- Build_Location_String --
- ---------------------------
-
- procedure Build_Location_String (Loc : Source_Ptr) is
- Ptr : Source_Ptr;
-
- begin
- Name_Len := 0;
-
- -- Loop through instantiations
-
- Ptr := Loc;
- loop
- Get_Name_String_And_Append
- (Reference_Name (Get_Source_File_Index (Ptr)));
- Add_Char_To_Name_Buffer (':');
- Add_Nat_To_Name_Buffer
- (Nat (Get_Logical_Line_Number (Ptr)));
-
- Ptr := Instantiation_Location (Ptr);
- exit when Ptr = No_Location;
- Add_Str_To_Name_Buffer (" instantiated at ");
- end loop;
-
- Name_Buffer (Name_Len + 1) := NUL;
- return;
- end Build_Location_String;
-
- -----------------------
- -- Get_Column_Number --
- -----------------------
-
- function Get_Column_Number (P : Source_Ptr) return Column_Number is
- S : Source_Ptr;
- C : Column_Number;
- Sindex : Source_File_Index;
- Src : Source_Buffer_Ptr;
-
- begin
- -- If the input source pointer is not a meaningful value then return
- -- at once with column number 1. This can happen for a file not found
- -- condition for a file loaded indirectly by RTE, and also perhaps on
- -- some unknown internal error conditions. In either case we certainly
- -- don't want to blow up.
-
- if P < 1 then
- return 1;
-
- else
- Sindex := Get_Source_File_Index (P);
- Src := Source_File.Table (Sindex).Source_Text;
- S := Line_Start (P);
- C := 1;
-
- while S < P loop
- if Src (S) = HT then
- C := (C - 1) / 8 * 8 + (8 + 1);
- else
- C := C + 1;
- end if;
-
- S := S + 1;
- end loop;
-
- return C;
- end if;
- end Get_Column_Number;
-
- -----------------------------
- -- Get_Logical_Line_Number --
- -----------------------------
-
- function Get_Logical_Line_Number
- (P : Source_Ptr)
- return Logical_Line_Number
- is
- SFR : Source_File_Record
- renames Source_File.Table (Get_Source_File_Index (P));
-
- L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
-
- begin
- if SFR.Num_SRef_Pragmas = 0 then
- return Logical_Line_Number (L);
- else
- return SFR.Logical_Lines_Table (L);
- end if;
- end Get_Logical_Line_Number;
-
- ------------------------------
- -- Get_Physical_Line_Number --
- ------------------------------
-
- function Get_Physical_Line_Number
- (P : Source_Ptr)
- return Physical_Line_Number
- is
- Sfile : Source_File_Index;
- Table : Lines_Table_Ptr;
- Lo : Physical_Line_Number;
- Hi : Physical_Line_Number;
- Mid : Physical_Line_Number;
- Loc : Source_Ptr;
-
- begin
- -- If the input source pointer is not a meaningful value then return
- -- at once with line number 1. This can happen for a file not found
- -- condition for a file loaded indirectly by RTE, and also perhaps on
- -- some unknown internal error conditions. In either case we certainly
- -- don't want to blow up.
-
- if P < 1 then
- return 1;
-
- -- Otherwise we can do the binary search
-
- else
- Sfile := Get_Source_File_Index (P);
- Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
- Table := Source_File.Table (Sfile).Lines_Table;
- Lo := 1;
- Hi := Source_File.Table (Sfile).Last_Source_Line;
-
- loop
- Mid := (Lo + Hi) / 2;
-
- if Loc < Table (Mid) then
- Hi := Mid - 1;
-
- else -- Loc >= Table (Mid)
-
- if Mid = Hi or else
- Loc < Table (Mid + 1)
- then
- return Mid;
- else
- Lo := Mid + 1;
- end if;
-
- end if;
-
- end loop;
- end if;
- end Get_Physical_Line_Number;
-
- ---------------------------
- -- Get_Source_File_Index --
- ---------------------------
-
- Source_Cache_First : Source_Ptr := 1;
- Source_Cache_Last : Source_Ptr := 0;
- -- Records the First and Last subscript values for the most recently
- -- referenced entry in the source table, to optimize the common case
- -- of repeated references to the same entry. The initial values force
- -- an initial search to set the cache value.
-
- Source_Cache_Index : Source_File_Index := No_Source_File;
- -- Contains the index of the entry corresponding to Source_Cache
-
- function Get_Source_File_Index
- (S : Source_Ptr)
- return Source_File_Index
- is
- begin
- if S in Source_Cache_First .. Source_Cache_Last then
- return Source_Cache_Index;
-
- else
- for J in 1 .. Source_File.Last loop
- if S in Source_File.Table (J).Source_First ..
- Source_File.Table (J).Source_Last
- then
- Source_Cache_Index := J;
- Source_Cache_First :=
- Source_File.Table (Source_Cache_Index).Source_First;
- Source_Cache_Last :=
- Source_File.Table (Source_Cache_Index).Source_Last;
- return Source_Cache_Index;
- end if;
- end loop;
- end if;
-
- -- We must find a matching entry in the above loop!
-
- raise Program_Error;
- end Get_Source_File_Index;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Source_File.Init;
- end Initialize;
-
- -------------------------
- -- Instantiation_Depth --
- -------------------------
-
- function Instantiation_Depth (S : Source_Ptr) return Nat is
- Sind : Source_File_Index;
- Sval : Source_Ptr;
- Depth : Nat;
-
- begin
- Sval := S;
- Depth := 0;
-
- loop
- Sind := Get_Source_File_Index (Sval);
- Sval := Instantiation (Sind);
- exit when Sval = No_Location;
- Depth := Depth + 1;
- end loop;
-
- return Depth;
- end Instantiation_Depth;
-
- ----------------------------
- -- Instantiation_Location --
- ----------------------------
-
- function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
- begin
- return Instantiation (Get_Source_File_Index (S));
- end Instantiation_Location;
-
- ----------------------
- -- Last_Source_File --
- ----------------------
-
- function Last_Source_File return Source_File_Index is
- begin
- return Source_File.Last;
- end Last_Source_File;
-
- ----------------
- -- Line_Start --
- ----------------
-
- function Line_Start (P : Source_Ptr) return Source_Ptr is
- Sindex : constant Source_File_Index := Get_Source_File_Index (P);
- Src : constant Source_Buffer_Ptr :=
- Source_File.Table (Sindex).Source_Text;
- Sfirst : constant Source_Ptr :=
- Source_File.Table (Sindex).Source_First;
- S : Source_Ptr;
-
- begin
- S := P;
-
- while S > Sfirst
- and then Src (S - 1) /= CR
- and then Src (S - 1) /= LF
- loop
- S := S - 1;
- end loop;
-
- return S;
- end Line_Start;
-
- function Line_Start
- (L : Physical_Line_Number;
- S : Source_File_Index)
- return Source_Ptr
- is
- begin
- return Source_File.Table (S).Lines_Table (L);
- end Line_Start;
-
- ----------
- -- Lock --
- ----------
-
- procedure Lock is
- begin
- Source_File.Locked := True;
- Source_File.Release;
- end Lock;
-
- ----------------------
- -- Num_Source_Files --
- ----------------------
-
- function Num_Source_Files return Nat is
- begin
- return Int (Source_File.Last) - Int (Source_File.First) + 1;
- end Num_Source_Files;
-
- ----------------------
- -- Num_Source_Lines --
- ----------------------
-
- function Num_Source_Lines (S : Source_File_Index) return Nat is
- begin
- return Nat (Source_File.Table (S).Last_Source_Line);
- end Num_Source_Lines;
-
- -----------------------
- -- Original_Location --
- -----------------------
-
- function Original_Location (S : Source_Ptr) return Source_Ptr is
- Sindex : Source_File_Index;
- Tindex : Source_File_Index;
-
- begin
- if S <= No_Location then
- return S;
-
- else
- Sindex := Get_Source_File_Index (S);
-
- if Instantiation (Sindex) = No_Location then
- return S;
-
- else
- Tindex := Template (Sindex);
- while Instantiation (Tindex) /= No_Location loop
- Tindex := Template (Tindex);
- end loop;
-
- return S - Source_First (Sindex) + Source_First (Tindex);
- end if;
- end if;
- end Original_Location;
-
- -------------------------
- -- Physical_To_Logical --
- -------------------------
-
- function Physical_To_Logical
- (Line : Physical_Line_Number;
- S : Source_File_Index)
- return Logical_Line_Number
- is
- SFR : Source_File_Record renames Source_File.Table (S);
-
- begin
- if SFR.Num_SRef_Pragmas = 0 then
- return Logical_Line_Number (Line);
- else
- return SFR.Logical_Lines_Table (Line);
- end if;
- end Physical_To_Logical;
-
- --------------------------------
- -- Register_Source_Ref_Pragma --
- --------------------------------
-
- procedure Register_Source_Ref_Pragma
- (File_Name : Name_Id;
- Stripped_File_Name : Name_Id;
- Mapped_Line : Nat;
- Line_After_Pragma : Physical_Line_Number)
- is
- SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
-
- function malloc
- (size : size_t)
- return Logical_Lines_Table_Ptr;
- pragma Import (C, malloc);
-
- ML : Logical_Line_Number;
-
- begin
- if File_Name /= No_Name then
- SFR.Full_Ref_Name := File_Name;
-
- if not Debug_Generated_Code then
- SFR.Debug_Source_Name := File_Name;
- end if;
-
- SFR.Reference_Name := Stripped_File_Name;
- SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
- end if;
-
- if SFR.Num_SRef_Pragmas = 1 then
- SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
- end if;
-
- if SFR.Logical_Lines_Table = null then
- SFR.Logical_Lines_Table :=
- malloc
- (size_t (SFR.Lines_Table_Max *
- Logical_Lines_Table_Type'Component_Size /
- Storage_Unit));
- end if;
-
- SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
-
- ML := Logical_Line_Number (Mapped_Line);
- for J in Line_After_Pragma .. SFR.Last_Source_Line loop
- SFR.Logical_Lines_Table (J) := ML;
- ML := ML + 1;
- end loop;
- end Register_Source_Ref_Pragma;
-
- ---------------------------
- -- Skip_Line_Terminators --
- ---------------------------
-
- -- There are two distinct concepts of line terminator in GNAT
-
- -- A logical line terminator is what corresponds to the "end of a line"
- -- as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
- -- acts as an end of logical line in this sense, and it is essentially
- -- irrelevant whether one or more appears in sequence (since if a
- -- sequence of such characters is regarded as separate ends of line,
- -- then the intervening logical lines are null in any case).
-
- -- A physical line terminator is a sequence of format effectors that
- -- is treated as ending a physical line. Physical lines have no Ada
- -- semantic significance, but they are significant for error reporting
- -- purposes, since errors are identified by line and column location.
-
- -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
- -- CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
- -- and CR alone in System 7. We don't know of any system using LF/CR, but
- -- it seems reasonable to include this case for consistency. In addition,
- -- we recognize any of these sequences in any of the operating systems,
- -- for better behavior in treating foreign files (e.g. a Unix file with
- -- LF terminators transferred to a DOS system).
-
- procedure Skip_Line_Terminators
- (P : in out Source_Ptr;
- Physical : out Boolean)
- is
- begin
- pragma Assert (Source (P) in Line_Terminator);
-
- if Source (P) = CR then
- if Source (P + 1) = LF then
- P := P + 2;
- else
- P := P + 1;
- end if;
-
- elsif Source (P) = LF then
- if Source (P + 1) = CR then
- P := P + 2;
- else
- P := P + 1;
- end if;
-
- else -- Source (P) = FF or else Source (P) = VT
- P := P + 1;
- Physical := False;
- return;
- end if;
-
- -- Fall through in the physical line terminator case. First deal with
- -- making a possible entry into the lines table if one is needed.
-
- -- Note: we are dealing with a real source file here, this cannot be
- -- the instantiation case, so we need not worry about Sloc adjustment.
-
- declare
- S : Source_File_Record
- renames Source_File.Table (Current_Source_File);
-
- begin
- Physical := True;
-
- -- Make entry in lines table if not already made (in some scan backup
- -- cases, we will be rescanning previously scanned source, so the
- -- entry may have already been made on the previous forward scan).
-
- if Source (P) /= EOF
- and then P > S.Lines_Table (S.Last_Source_Line)
- then
- Add_Line_Tables_Entry (S, P);
- end if;
- end;
- end Skip_Line_Terminators;
-
- -------------------
- -- Source_Offset --
- -------------------
-
- function Source_Offset (S : Source_Ptr) return Nat is
- Sindex : constant Source_File_Index := Get_Source_File_Index (S);
- Sfirst : constant Source_Ptr :=
- Source_File.Table (Sindex).Source_First;
-
- begin
- return Nat (S - Sfirst);
- end Source_Offset;
-
- ------------------------
- -- Top_Level_Location --
- ------------------------
-
- function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
- Oldloc : Source_Ptr;
- Newloc : Source_Ptr;
-
- begin
- Newloc := S;
- loop
- Oldloc := Newloc;
- Newloc := Instantiation_Location (Oldloc);
- exit when Newloc = No_Location;
- end loop;
-
- return Oldloc;
- end Top_Level_Location;
-
- ---------------
- -- Tree_Read --
- ---------------
-
- procedure Tree_Read is
- begin
- -- First we must free any old source buffer pointers
-
- if not First_Time_Around then
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- procedure Free_Ptr is new Unchecked_Deallocation
- (Big_Source_Buffer, Source_Buffer_Ptr);
-
- -- Note: we are using free here, because we used malloc
- -- or realloc directly to allocate the tables. That is
- -- because we were playing the big array trick.
-
- procedure free (X : Lines_Table_Ptr);
- pragma Import (C, free, "free");
-
- procedure freel (X : Logical_Lines_Table_Ptr);
- pragma Import (C, freel, "free");
-
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- Tmp1 : Source_Buffer_Ptr;
-
- begin
- if S.Instantiation /= No_Location then
- null;
-
- else
- -- We have to recreate a proper pointer to the actual array
- -- from the zero origin pointer stored in the source table.
-
- Tmp1 :=
- To_Source_Buffer_Ptr
- (S.Source_Text (S.Source_First)'Address);
- Free_Ptr (Tmp1);
-
- if S.Lines_Table /= null then
- free (S.Lines_Table);
- S.Lines_Table := null;
- end if;
-
- if S.Logical_Lines_Table /= null then
- freel (S.Logical_Lines_Table);
- S.Logical_Lines_Table := null;
- end if;
- end if;
- end;
- end loop;
- end if;
-
- -- Reset source cache pointers to force new read
-
- Source_Cache_First := 1;
- Source_Cache_Last := 0;
-
- -- Read in source file table
-
- Source_File.Tree_Read;
-
- -- The pointers we read in there for the source buffer and lines
- -- table pointers are junk. We now read in the actual data that
- -- is referenced by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- begin
- -- For the instantiation case, we do not read in any data. Instead
- -- we share the data for the generic template entry. Since the
- -- template always occurs first, we can safetly refer to its data.
-
- if S.Instantiation /= No_Location then
- declare
- ST : Source_File_Record renames
- Source_File.Table (S.Template);
-
- begin
- -- The lines tables are copied from the template entry
-
- S.Lines_Table :=
- Source_File.Table (S.Template).Lines_Table;
- S.Logical_Lines_Table :=
- Source_File.Table (S.Template).Logical_Lines_Table;
-
- -- In the case of the source table pointer, we share the
- -- same data as the generic template, but the virtual origin
- -- is adjusted. For example, if the first subscript of the
- -- template is 100, and that of the instantiation is 200,
- -- then the instantiation pointer is obtained by subtracting
- -- 100 from the template pointer.
-
- declare
- pragma Suppress (All_Checks);
-
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- begin
- S.Source_Text :=
- To_Source_Buffer_Ptr
- (ST.Source_Text
- (ST.Source_First - S.Source_First)'Address);
- end;
- end;
-
- -- Normal case (non-instantiation)
-
- else
- First_Time_Around := False;
- S.Lines_Table := null;
- S.Logical_Lines_Table := null;
- Alloc_Line_Tables (S, Int (S.Last_Source_Line));
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Lines_Table (J)));
- end loop;
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Allocate source buffer and read in the data and then set the
- -- virtual origin to point to the logical zero'th element. This
- -- address must be computed with subscript checks turned off.
-
- declare
- subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
- type Text_Buffer_Ptr is access B;
- T : Text_Buffer_Ptr;
-
- pragma Suppress (All_Checks);
-
- function To_Source_Buffer_Ptr is new
- Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- begin
- T := new B;
-
- Tree_Read_Data (T (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
-
- S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
- end;
- end if;
- end;
- end loop;
- end Tree_Read;
-
- ----------------
- -- Tree_Write --
- ----------------
-
- procedure Tree_Write is
- begin
- Source_File.Tree_Write;
-
- -- The pointers we wrote out there for the source buffer and lines
- -- table pointers are junk, we now write out the actual data that
- -- is referenced by these two fields.
-
- for J in Source_File.First .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (J);
-
- begin
- -- For instantiations, there is nothing to do, since the data is
- -- shared with the generic template. When the tree is read, the
- -- pointers must be set, but no extra data needs to be written.
-
- if S.Instantiation /= No_Location then
- null;
-
- -- For the normal case, write out the data of the tables
-
- else
- -- Lines table
-
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Lines_Table (J)));
- end loop;
-
- -- Logical lines table if present
-
- if S.Num_SRef_Pragmas /= 0 then
- for J in 1 .. S.Last_Source_Line loop
- Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
- end loop;
- end if;
-
- -- Source buffer
-
- Tree_Write_Data
- (S.Source_Text (S.Source_First)'Address,
- Int (S.Source_Last) - Int (S.Source_First) + 1);
- end if;
- end;
- end loop;
- end Tree_Write;
-
- --------------------
- -- Write_Location --
- --------------------
-
- procedure Write_Location (P : Source_Ptr) is
- begin
- if P = No_Location then
- Write_Str ("<no location>");
-
- elsif P <= Standard_Location then
- Write_Str ("<standard location>");
-
- else
- declare
- SI : constant Source_File_Index := Get_Source_File_Index (P);
-
- begin
- Write_Name (Debug_Source_Name (SI));
- Write_Char (':');
- Write_Int (Int (Get_Logical_Line_Number (P)));
- Write_Char (':');
- Write_Int (Int (Get_Column_Number (P)));
-
- if Instantiation (SI) /= No_Location then
- Write_Str (" [");
- Write_Location (Instantiation (SI));
- Write_Char (']');
- end if;
- end;
- end if;
- end Write_Location;
-
- ----------------------
- -- Write_Time_Stamp --
- ----------------------
-
- procedure Write_Time_Stamp (S : Source_File_Index) is
- T : constant Time_Stamp_Type := Time_Stamp (S);
- P : Natural;
-
- begin
- if T (1) = '9' then
- Write_Str ("19");
- P := 0;
- else
- Write_Char (T (1));
- Write_Char (T (2));
- P := 2;
- end if;
-
- Write_Char (T (P + 1));
- Write_Char (T (P + 2));
- Write_Char ('-');
-
- Write_Char (T (P + 3));
- Write_Char (T (P + 4));
- Write_Char ('-');
-
- Write_Char (T (P + 5));
- Write_Char (T (P + 6));
- Write_Char (' ');
-
- Write_Char (T (P + 7));
- Write_Char (T (P + 8));
- Write_Char (':');
-
- Write_Char (T (P + 9));
- Write_Char (T (P + 10));
- Write_Char (':');
-
- Write_Char (T (P + 11));
- Write_Char (T (P + 12));
- end Write_Time_Stamp;
-
- ----------------------------------------------
- -- Access Subprograms for Source File Table --
- ----------------------------------------------
-
- function Debug_Source_Name (S : SFI) return File_Name_Type is
- begin
- return Source_File.Table (S).Debug_Source_Name;
- end Debug_Source_Name;
-
- function File_Name (S : SFI) return File_Name_Type is
- begin
- return Source_File.Table (S).File_Name;
- end File_Name;
-
- function First_Mapped_Line (S : SFI) return Logical_Line_Number is
- begin
- return Source_File.Table (S).First_Mapped_Line;
- end First_Mapped_Line;
-
- function Full_File_Name (S : SFI) return File_Name_Type is
- begin
- return Source_File.Table (S).Full_File_Name;
- end Full_File_Name;
-
- function Full_Ref_Name (S : SFI) return File_Name_Type is
- begin
- return Source_File.Table (S).Full_Ref_Name;
- end Full_Ref_Name;
-
- function Identifier_Casing (S : SFI) return Casing_Type is
- begin
- return Source_File.Table (S).Identifier_Casing;
- end Identifier_Casing;
-
- function Instantiation (S : SFI) return Source_Ptr is
- begin
- return Source_File.Table (S).Instantiation;
- end Instantiation;
-
- function Keyword_Casing (S : SFI) return Casing_Type is
- begin
- return Source_File.Table (S).Keyword_Casing;
- end Keyword_Casing;
-
- function Last_Source_Line (S : SFI) return Physical_Line_Number is
- begin
- return Source_File.Table (S).Last_Source_Line;
- end Last_Source_Line;
-
- function License (S : SFI) return License_Type is
- begin
- return Source_File.Table (S).License;
- end License;
-
- function Num_SRef_Pragmas (S : SFI) return Nat is
- begin
- return Source_File.Table (S).Num_SRef_Pragmas;
- end Num_SRef_Pragmas;
-
- function Reference_Name (S : SFI) return File_Name_Type is
- begin
- return Source_File.Table (S).Reference_Name;
- end Reference_Name;
-
- function Source_Checksum (S : SFI) return Word is
- begin
- return Source_File.Table (S).Source_Checksum;
- end Source_Checksum;
-
- function Source_First (S : SFI) return Source_Ptr is
- begin
- return Source_File.Table (S).Source_First;
- end Source_First;
-
- function Source_Last (S : SFI) return Source_Ptr is
- begin
- return Source_File.Table (S).Source_Last;
- end Source_Last;
-
- function Source_Text (S : SFI) return Source_Buffer_Ptr is
- begin
- return Source_File.Table (S).Source_Text;
- end Source_Text;
-
- function Template (S : SFI) return SFI is
- begin
- return Source_File.Table (S).Template;
- end Template;
-
- function Time_Stamp (S : SFI) return Time_Stamp_Type is
- begin
- return Source_File.Table (S).Time_Stamp;
- end Time_Stamp;
-
- ------------------------------------------
- -- Set Procedures for Source File Table --
- ------------------------------------------
-
- procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
- begin
- Source_File.Table (S).Identifier_Casing := C;
- end Set_Identifier_Casing;
-
- procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
- begin
- Source_File.Table (S).Keyword_Casing := C;
- end Set_Keyword_Casing;
-
- procedure Set_License (S : SFI; L : License_Type) is
- begin
- Source_File.Table (S).License := L;
- end Set_License;
-
- --------
- -- wl --
- --------
-
- procedure wl (P : Source_Ptr) is
- begin
- Write_Location (P);
- Write_Eol;
- end wl;
-
-end Sinput;
projects / msp430-gcc.git / blobdiff