URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-awk.adb] - Blame information for rev 729

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              G N A T . A W K                             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2000-2011, AdaCore                     --
--                                                                          --
-- 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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Unchecked_Deallocation;
 
with GNAT.Directory_Operations;
with GNAT.Dynamic_Tables;
with GNAT.OS_Lib;
 
package body GNAT.AWK is
 
   use Ada;
   use Ada.Strings.Unbounded;
 
   -----------------------
   -- Local subprograms --
   -----------------------
 
   --  The following two subprograms provide a functional interface to the
   --  two special session variables, that are manipulated explicitly by
   --  Finalize, but must be declared after Finalize to prevent static
   --  elaboration warnings.
 
   function Get_Def return Session_Data_Access;
   procedure Set_Cur;
 
   ----------------
   -- Split mode --
   ----------------
 
   package Split is
 
      type Mode is abstract tagged null record;
      --  This is the main type which is declared abstract. This type must be
      --  derived for each split style.
 
      type Mode_Access is access Mode'Class;
 
      procedure Current_Line (S : Mode; Session : Session_Type)
        is abstract;
      --  Split current line of Session using split mode S
 
      ------------------------
      -- Split on separator --
      ------------------------
 
      type Separator (Size : Positive) is new Mode with record
         Separators : String (1 .. Size);
      end record;
 
      procedure Current_Line
        (S       : Separator;
         Session : Session_Type);
 
      ---------------------
      -- Split on column --
      ---------------------
 
      type Column (Size : Positive) is new Mode with record
         Columns : Widths_Set (1 .. Size);
      end record;
 
      procedure Current_Line (S : Column; Session : Session_Type);
 
   end Split;
 
   procedure Free is new Unchecked_Deallocation
     (Split.Mode'Class, Split.Mode_Access);
 
   ----------------
   -- File_Table --
   ----------------
 
   type AWK_File is access String;
 
   package File_Table is
      new Dynamic_Tables (AWK_File, Natural, 1, 5, 50);
   --  List of file names associated with a Session
 
   procedure Free is new Unchecked_Deallocation (String, AWK_File);
 
   -----------------
   -- Field_Table --
   -----------------
 
   type Field_Slice is record
      First : Positive;
      Last  : Natural;
   end record;
   --  This is a field slice (First .. Last) in session's current line
 
   package Field_Table is
      new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100);
   --  List of fields for the current line
 
   --------------
   -- Patterns --
   --------------
 
   --  Define all patterns style: exact string, regular expression, boolean
   --  function.
 
   package Patterns is
 
      type Pattern is abstract tagged null record;
      --  This is the main type which is declared abstract. This type must be
      --  derived for each patterns style.
 
      type Pattern_Access is access Pattern'Class;
 
      function Match
        (P       : Pattern;
         Session : Session_Type) return Boolean
      is abstract;
      --  Returns True if P match for the current session and False otherwise
 
      procedure Release (P : in out Pattern);
      --  Release memory used by the pattern structure
 
      --------------------------
      -- Exact string pattern --
      --------------------------
 
      type String_Pattern is new Pattern with record
         Str  : Unbounded_String;
         Rank : Count;
      end record;
 
      function Match
        (P       : String_Pattern;
         Session : Session_Type) return Boolean;
 
      --------------------------------
      -- Regular expression pattern --
      --------------------------------
 
      type Pattern_Matcher_Access is access Regpat.Pattern_Matcher;
 
      type Regexp_Pattern is new Pattern with record
         Regx : Pattern_Matcher_Access;
         Rank : Count;
      end record;
 
      function Match
        (P       : Regexp_Pattern;
         Session : Session_Type) return Boolean;
 
      procedure Release (P : in out Regexp_Pattern);
 
      ------------------------------
      -- Boolean function pattern --
      ------------------------------
 
      type Callback_Pattern is new Pattern with record
         Pattern : Pattern_Callback;
      end record;
 
      function Match
        (P       : Callback_Pattern;
         Session : Session_Type) return Boolean;
 
   end Patterns;
 
   procedure Free is new Unchecked_Deallocation
     (Patterns.Pattern'Class, Patterns.Pattern_Access);
 
   -------------
   -- Actions --
   -------------
 
   --  Define all action style : simple call, call with matches
 
   package Actions is
 
      type Action is abstract tagged null record;
      --  This is the main type which is declared abstract. This type must be
      --  derived for each action style.
 
      type Action_Access is access Action'Class;
 
      procedure Call
        (A       : Action;
         Session : Session_Type) is abstract;
      --  Call action A as required
 
      -------------------
      -- Simple action --
      -------------------
 
      type Simple_Action is new Action with record
         Proc : Action_Callback;
      end record;
 
      procedure Call
        (A       : Simple_Action;
         Session : Session_Type);
 
      -------------------------
      -- Action with matches --
      -------------------------
 
      type Match_Action is new Action with record
         Proc : Match_Action_Callback;
      end record;
 
      procedure Call
        (A       : Match_Action;
         Session : Session_Type);
 
   end Actions;
 
   procedure Free is new Unchecked_Deallocation
     (Actions.Action'Class, Actions.Action_Access);
 
   --------------------------
   -- Pattern/Action table --
   --------------------------
 
   type Pattern_Action is record
      Pattern : Patterns.Pattern_Access;  -- If Pattern is True
      Action  : Actions.Action_Access;    -- Action will be called
   end record;
 
   package Pattern_Action_Table is
      new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50);
 
   ------------------
   -- Session Data --
   ------------------
 
   type Session_Data is record
      Current_File : Text_IO.File_Type;
      Current_Line : Unbounded_String;
      Separators   : Split.Mode_Access;
      Files        : File_Table.Instance;
      File_Index   : Natural := 0;
      Fields       : Field_Table.Instance;
      Filters      : Pattern_Action_Table.Instance;
      NR           : Natural := 0;
      FNR          : Natural := 0;
      Matches      : Regpat.Match_Array (0 .. 100);
      --  Latest matches for the regexp pattern
   end record;
 
   procedure Free is
      new Unchecked_Deallocation (Session_Data, Session_Data_Access);
 
   --------------
   -- Finalize --
   --------------
 
   procedure Finalize (Session : in out Session_Type) is
   begin
      --  We release the session data only if it is not the default session
 
      if Session.Data /= Get_Def then
         --  Release separators
 
         Free (Session.Data.Separators);
 
         Free (Session.Data);
 
         --  Since we have closed the current session, set it to point now to
         --  the default session.
 
         Set_Cur;
      end if;
   end Finalize;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize (Session : in out Session_Type) is
   begin
      Session.Data := new Session_Data;
 
      --  Initialize separators
 
      Session.Data.Separators :=
        new Split.Separator'(Default_Separators'Length, Default_Separators);
 
      --  Initialize all tables
 
      File_Table.Init  (Session.Data.Files);
      Field_Table.Init (Session.Data.Fields);
      Pattern_Action_Table.Init (Session.Data.Filters);
   end Initialize;
 
   -----------------------
   -- Session Variables --
   -----------------------
 
   Def_Session : Session_Type;
   Cur_Session : Session_Type;
 
   ----------------------
   -- Private Services --
   ----------------------
 
   function Always_True return Boolean;
   --  A function that always returns True
 
   function Apply_Filters
     (Session : Session_Type) return Boolean;
   --  Apply any filters for which the Pattern is True for Session. It returns
   --  True if a least one filters has been applied (i.e. associated action
   --  callback has been called).
 
   procedure Open_Next_File
     (Session : Session_Type);
   pragma Inline (Open_Next_File);
   --  Open next file for Session closing current file if needed. It raises
   --  End_Error if there is no more file in the table.
 
   procedure Raise_With_Info
     (E       : Exceptions.Exception_Id;
      Message : String;
      Session : Session_Type);
   pragma No_Return (Raise_With_Info);
   --  Raises exception E with the message prepended with the current line
   --  number and the filename if possible.
 
   procedure Read_Line (Session : Session_Type);
   --  Read a line for the Session and set Current_Line
 
   procedure Split_Line (Session : Session_Type);
   --  Split session's Current_Line according to the session separators and
   --  set the Fields table. This procedure can be called at any time.
 
   ----------------------
   -- Private Packages --
   ----------------------
 
   -------------
   -- Actions --
   -------------
 
   package body Actions is
 
      ----------
      -- Call --
      ----------
 
      procedure Call
        (A       : Simple_Action;
         Session : Session_Type)
      is
         pragma Unreferenced (Session);
      begin
         A.Proc.all;
      end Call;
 
      ----------
      -- Call --
      ----------
 
      procedure Call
        (A       : Match_Action;
         Session : Session_Type)
      is
      begin
         A.Proc (Session.Data.Matches);
      end Call;
 
   end Actions;
 
   --------------
   -- Patterns --
   --------------
 
   package body Patterns is
 
      -----------
      -- Match --
      -----------
 
      function Match
        (P       : String_Pattern;
         Session : Session_Type) return Boolean
      is
      begin
         return P.Str = Field (P.Rank, Session);
      end Match;
 
      -----------
      -- Match --
      -----------
 
      function Match
        (P       : Regexp_Pattern;
         Session : Session_Type) return Boolean
      is
         use type Regpat.Match_Location;
      begin
         Regpat.Match
           (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches);
         return Session.Data.Matches (0) /= Regpat.No_Match;
      end Match;
 
      -----------
      -- Match --
      -----------
 
      function Match
        (P       : Callback_Pattern;
         Session : Session_Type) return Boolean
      is
         pragma Unreferenced (Session);
      begin
         return P.Pattern.all;
      end Match;
 
      -------------
      -- Release --
      -------------
 
      procedure Release (P : in out Pattern) is
         pragma Unreferenced (P);
      begin
         null;
      end Release;
 
      -------------
      -- Release --
      -------------
 
      procedure Release (P : in out Regexp_Pattern) is
         procedure Free is new Unchecked_Deallocation
           (Regpat.Pattern_Matcher, Pattern_Matcher_Access);
      begin
         Free (P.Regx);
      end Release;
 
   end Patterns;
 
   -----------
   -- Split --
   -----------
 
   package body Split is
 
      use Ada.Strings;
 
      ------------------
      -- Current_Line --
      ------------------
 
      procedure Current_Line (S : Separator; Session : Session_Type) is
         Line   : constant String := To_String (Session.Data.Current_Line);
         Fields : Field_Table.Instance renames Session.Data.Fields;
         Seps   : constant Maps.Character_Set := Maps.To_Set (S.Separators);
 
         Start  : Natural;
         Stop   : Natural;
 
      begin
         --  First field start here
 
         Start := Line'First;
 
         --  Record the first field start position which is the first character
         --  in the line.
 
         Field_Table.Increment_Last (Fields);
         Fields.Table (Field_Table.Last (Fields)).First := Start;
 
         loop
            --  Look for next separator
 
            Stop := Fixed.Index
              (Source => Line (Start .. Line'Last),
               Set    => Seps);
 
            exit when Stop = 0;
 
            Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1;
 
            --  If separators are set to the default (space and tab) we skip
            --  all spaces and tabs following current field.
 
            if S.Separators = Default_Separators then
               Start := Fixed.Index
                 (Line (Stop + 1 .. Line'Last),
                  Maps.To_Set (Default_Separators),
                  Outside,
                  Strings.Forward);
 
               if Start = 0 then
                  Start := Stop + 1;
               end if;
 
            else
               Start := Stop + 1;
            end if;
 
            --  Record in the field table the start of this new field
 
            Field_Table.Increment_Last (Fields);
            Fields.Table (Field_Table.Last (Fields)).First := Start;
 
         end loop;
 
         Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
      end Current_Line;
 
      ------------------
      -- Current_Line --
      ------------------
 
      procedure Current_Line (S : Column; Session : Session_Type) is
         Line   : constant String := To_String (Session.Data.Current_Line);
         Fields : Field_Table.Instance renames Session.Data.Fields;
         Start  : Positive := Line'First;
 
      begin
         --  Record the first field start position which is the first character
         --  in the line.
 
         for C in 1 .. S.Columns'Length loop
 
            Field_Table.Increment_Last (Fields);
 
            Fields.Table (Field_Table.Last (Fields)).First := Start;
 
            Start := Start + S.Columns (C);
 
            Fields.Table (Field_Table.Last (Fields)).Last := Start - 1;
 
         end loop;
 
         --  If there is some remaining character on the line, add them in a
         --  new field.
 
         if Start - 1 < Line'Length then
 
            Field_Table.Increment_Last (Fields);
 
            Fields.Table (Field_Table.Last (Fields)).First := Start;
 
            Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
         end if;
      end Current_Line;
 
   end Split;
 
   --------------
   -- Add_File --
   --------------
 
   procedure Add_File
     (Filename : String;
      Session  : Session_Type)
   is
      Files : File_Table.Instance renames Session.Data.Files;
 
   begin
      if OS_Lib.Is_Regular_File (Filename) then
         File_Table.Increment_Last (Files);
         Files.Table (File_Table.Last (Files)) := new String'(Filename);
      else
         Raise_With_Info
           (File_Error'Identity,
            "File " & Filename & " not found.",
            Session);
      end if;
   end Add_File;
 
   procedure Add_File
     (Filename : String)
   is
 
   begin
      Add_File (Filename, Cur_Session);
   end Add_File;
 
   ---------------
   -- Add_Files --
   ---------------
 
   procedure Add_Files
     (Directory             : String;
      Filenames             : String;
      Number_Of_Files_Added : out Natural;
      Session               : Session_Type)
   is
      use Directory_Operations;
 
      Dir      : Dir_Type;
      Filename : String (1 .. 200);
      Last     : Natural;
 
   begin
      Number_Of_Files_Added := 0;
 
      Open (Dir, Directory);
 
      loop
         Read (Dir, Filename, Last);
         exit when Last = 0;
 
         Add_File (Filename (1 .. Last), Session);
         Number_Of_Files_Added := Number_Of_Files_Added + 1;
      end loop;
 
      Close (Dir);
 
   exception
      when others =>
         Raise_With_Info
           (File_Error'Identity,
            "Error scanning directory " & Directory
            & " for files " & Filenames & '.',
            Session);
   end Add_Files;
 
   procedure Add_Files
     (Directory             : String;
      Filenames             : String;
      Number_Of_Files_Added : out Natural)
   is
 
   begin
      Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session);
   end Add_Files;
 
   -----------------
   -- Always_True --
   -----------------
 
   function Always_True return Boolean is
   begin
      return True;
   end Always_True;
 
   -------------------
   -- Apply_Filters --
   -------------------
 
   function Apply_Filters
     (Session : Session_Type) return Boolean
   is
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
      Results : Boolean := False;
 
   begin
      --  Iterate through the filters table, if pattern match call action
 
      for F in 1 .. Pattern_Action_Table.Last (Filters) loop
         if Patterns.Match (Filters.Table (F).Pattern.all, Session) then
            Results := True;
            Actions.Call (Filters.Table (F).Action.all, Session);
         end if;
      end loop;
 
      return Results;
   end Apply_Filters;
 
   -----------
   -- Close --
   -----------
 
   procedure Close (Session : Session_Type) is
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
      Files   : File_Table.Instance renames Session.Data.Files;
 
   begin
      --  Close current file if needed
 
      if Text_IO.Is_Open (Session.Data.Current_File) then
         Text_IO.Close (Session.Data.Current_File);
      end if;
 
      --  Release Filters table
 
      for F in 1 .. Pattern_Action_Table.Last (Filters) loop
         Patterns.Release (Filters.Table (F).Pattern.all);
         Free (Filters.Table (F).Pattern);
         Free (Filters.Table (F).Action);
      end loop;
 
      for F in 1 .. File_Table.Last (Files) loop
         Free (Files.Table (F));
      end loop;
 
      File_Table.Set_Last (Session.Data.Files, 0);
      Field_Table.Set_Last (Session.Data.Fields, 0);
      Pattern_Action_Table.Set_Last (Session.Data.Filters, 0);
 
      Session.Data.NR := 0;
      Session.Data.FNR := 0;
      Session.Data.File_Index := 0;
      Session.Data.Current_Line := Null_Unbounded_String;
   end Close;
 
   ---------------------
   -- Current_Session --
   ---------------------
 
   function Current_Session return not null access Session_Type is
   begin
      return Cur_Session.Self;
   end Current_Session;
 
   ---------------------
   -- Default_Session --
   ---------------------
 
   function Default_Session return not null access Session_Type is
   begin
      return Def_Session.Self;
   end Default_Session;
 
   --------------------
   -- Discrete_Field --
   --------------------
 
   function Discrete_Field
     (Rank    : Count;
      Session : Session_Type) return Discrete
   is
   begin
      return Discrete'Value (Field (Rank, Session));
   end Discrete_Field;
 
   function Discrete_Field_Current_Session
     (Rank    : Count) return Discrete is
      function Do_It is new Discrete_Field (Discrete);
   begin
      return Do_It (Rank, Cur_Session);
   end Discrete_Field_Current_Session;
 
   -----------------
   -- End_Of_Data --
   -----------------
 
   function End_Of_Data
     (Session : Session_Type) return Boolean
   is
   begin
      return Session.Data.File_Index = File_Table.Last (Session.Data.Files)
        and then End_Of_File (Session);
   end End_Of_Data;
 
   function End_Of_Data
     return Boolean
   is
   begin
      return End_Of_Data (Cur_Session);
   end End_Of_Data;
 
   -----------------
   -- End_Of_File --
   -----------------
 
   function End_Of_File
     (Session : Session_Type) return Boolean
   is
   begin
      return Text_IO.End_Of_File (Session.Data.Current_File);
   end End_Of_File;
 
   function End_Of_File
     return Boolean
   is
   begin
      return End_Of_File (Cur_Session);
   end End_Of_File;
 
   -----------
   -- Field --
   -----------
 
   function Field
     (Rank    : Count;
      Session : Session_Type) return String
   is
      Fields : Field_Table.Instance renames Session.Data.Fields;
 
   begin
      if Rank > Number_Of_Fields (Session) then
         Raise_With_Info
           (Field_Error'Identity,
            "Field number" & Count'Image (Rank) & " does not exist.",
            Session);
 
      elsif Rank = 0 then
 
         --  Returns the whole line, this is what $0 does under Session_Type
 
         return To_String (Session.Data.Current_Line);
 
      else
         return Slice (Session.Data.Current_Line,
                       Fields.Table (Positive (Rank)).First,
                       Fields.Table (Positive (Rank)).Last);
      end if;
   end Field;
 
   function Field
     (Rank    : Count) return String
   is
   begin
      return Field (Rank, Cur_Session);
   end Field;
 
   function Field
     (Rank    : Count;
      Session : Session_Type) return Integer
   is
   begin
      return Integer'Value (Field (Rank, Session));
 
   exception
      when Constraint_Error =>
         Raise_With_Info
           (Field_Error'Identity,
            "Field number" & Count'Image (Rank)
            & " cannot be converted to an integer.",
            Session);
   end Field;
 
   function Field
     (Rank    : Count) return Integer
   is
   begin
      return Field (Rank, Cur_Session);
   end Field;
 
   function Field
     (Rank    : Count;
      Session : Session_Type) return Float
   is
   begin
      return Float'Value (Field (Rank, Session));
 
   exception
      when Constraint_Error =>
         Raise_With_Info
           (Field_Error'Identity,
            "Field number" & Count'Image (Rank)
            & " cannot be converted to a float.",
            Session);
   end Field;
 
   function Field
     (Rank    : Count) return Float
   is
   begin
      return Field (Rank, Cur_Session);
   end Field;
 
   ----------
   -- File --
   ----------
 
   function File
     (Session : Session_Type) return String
   is
      Files : File_Table.Instance renames Session.Data.Files;
 
   begin
      if Session.Data.File_Index = 0 then
         return "??";
      else
         return Files.Table (Session.Data.File_Index).all;
      end if;
   end File;
 
   function File
     return String
   is
   begin
      return File (Cur_Session);
   end File;
 
   --------------------
   -- For_Every_Line --
   --------------------
 
   procedure For_Every_Line
     (Separators : String        := Use_Current;
      Filename   : String        := Use_Current;
      Callbacks  : Callback_Mode := None;
      Session    : Session_Type)
   is
      Quit : Boolean;
 
   begin
      Open (Separators, Filename, Session);
 
      while not End_Of_Data (Session) loop
         Read_Line (Session);
         Split_Line (Session);
 
         if Callbacks in Only .. Pass_Through then
            declare
               Discard : Boolean;
               pragma Unreferenced (Discard);
            begin
               Discard := Apply_Filters (Session);
            end;
         end if;
 
         if Callbacks /= Only then
            Quit := False;
            Action (Quit);
            exit when Quit;
         end if;
      end loop;
 
      Close (Session);
   end For_Every_Line;
 
   procedure For_Every_Line_Current_Session
     (Separators : String        := Use_Current;
      Filename   : String        := Use_Current;
      Callbacks  : Callback_Mode := None)
   is
      procedure Do_It is new For_Every_Line (Action);
   begin
      Do_It (Separators, Filename, Callbacks, Cur_Session);
   end For_Every_Line_Current_Session;
 
   --------------
   -- Get_Line --
   --------------
 
   procedure Get_Line
     (Callbacks : Callback_Mode := None;
      Session   : Session_Type)
   is
      Filter_Active : Boolean;
 
   begin
      if not Text_IO.Is_Open (Session.Data.Current_File) then
         raise File_Error;
      end if;
 
      loop
         Read_Line (Session);
         Split_Line (Session);
 
         case Callbacks is
 
            when None =>
               exit;
 
            when Only =>
               Filter_Active := Apply_Filters (Session);
               exit when not Filter_Active;
 
            when Pass_Through =>
               Filter_Active := Apply_Filters (Session);
               exit;
 
         end case;
      end loop;
   end Get_Line;
 
   procedure Get_Line
     (Callbacks : Callback_Mode := None)
   is
   begin
      Get_Line (Callbacks, Cur_Session);
   end Get_Line;
 
   ----------------------
   -- Number_Of_Fields --
   ----------------------
 
   function Number_Of_Fields
     (Session : Session_Type) return Count
   is
   begin
      return Count (Field_Table.Last (Session.Data.Fields));
   end Number_Of_Fields;
 
   function Number_Of_Fields
     return Count
   is
   begin
      return Number_Of_Fields (Cur_Session);
   end Number_Of_Fields;
 
   --------------------------
   -- Number_Of_File_Lines --
   --------------------------
 
   function Number_Of_File_Lines
     (Session : Session_Type) return Count
   is
   begin
      return Count (Session.Data.FNR);
   end Number_Of_File_Lines;
 
   function Number_Of_File_Lines
     return Count
   is
   begin
      return Number_Of_File_Lines (Cur_Session);
   end Number_Of_File_Lines;
 
   ---------------------
   -- Number_Of_Files --
   ---------------------
 
   function Number_Of_Files
     (Session : Session_Type) return Natural
   is
      Files : File_Table.Instance renames Session.Data.Files;
   begin
      return File_Table.Last (Files);
   end Number_Of_Files;
 
   function Number_Of_Files
     return Natural
   is
   begin
      return Number_Of_Files (Cur_Session);
   end Number_Of_Files;
 
   ---------------------
   -- Number_Of_Lines --
   ---------------------
 
   function Number_Of_Lines
     (Session : Session_Type) return Count
   is
   begin
      return Count (Session.Data.NR);
   end Number_Of_Lines;
 
   function Number_Of_Lines
     return Count
   is
   begin
      return Number_Of_Lines (Cur_Session);
   end Number_Of_Lines;
 
   ----------
   -- Open --
   ----------
 
   procedure Open
     (Separators : String       := Use_Current;
      Filename   : String       := Use_Current;
      Session    : Session_Type)
   is
   begin
      if Text_IO.Is_Open (Session.Data.Current_File) then
         raise Session_Error;
      end if;
 
      if Filename /= Use_Current then
         File_Table.Init (Session.Data.Files);
         Add_File (Filename, Session);
      end if;
 
      if Separators /= Use_Current then
         Set_Field_Separators (Separators, Session);
      end if;
 
      Open_Next_File (Session);
 
   exception
      when End_Error =>
         raise File_Error;
   end Open;
 
   procedure Open
     (Separators : String       := Use_Current;
      Filename   : String       := Use_Current)
   is
   begin
      Open (Separators, Filename, Cur_Session);
   end Open;
 
   --------------------
   -- Open_Next_File --
   --------------------
 
   procedure Open_Next_File
     (Session : Session_Type)
   is
      Files : File_Table.Instance renames Session.Data.Files;
 
   begin
      if Text_IO.Is_Open (Session.Data.Current_File) then
         Text_IO.Close (Session.Data.Current_File);
      end if;
 
      Session.Data.File_Index := Session.Data.File_Index + 1;
 
      --  If there are no mores file in the table, raise End_Error
 
      if Session.Data.File_Index > File_Table.Last (Files) then
         raise End_Error;
      end if;
 
      Text_IO.Open
        (File => Session.Data.Current_File,
         Name => Files.Table (Session.Data.File_Index).all,
         Mode => Text_IO.In_File);
   end Open_Next_File;
 
   -----------
   -- Parse --
   -----------
 
   procedure Parse
     (Separators : String       := Use_Current;
      Filename   : String       := Use_Current;
      Session    : Session_Type)
   is
      Filter_Active : Boolean;
      pragma Unreferenced (Filter_Active);
 
   begin
      Open (Separators, Filename, Session);
 
      while not End_Of_Data (Session) loop
         Get_Line (None, Session);
         Filter_Active := Apply_Filters (Session);
      end loop;
 
      Close (Session);
   end Parse;
 
   procedure Parse
     (Separators : String       := Use_Current;
      Filename   : String       := Use_Current)
   is
   begin
      Parse (Separators, Filename, Cur_Session);
   end Parse;
 
   ---------------------
   -- Raise_With_Info --
   ---------------------
 
   procedure Raise_With_Info
     (E       : Exceptions.Exception_Id;
      Message : String;
      Session : Session_Type)
   is
      function Filename return String;
      --  Returns current filename and "??" if this information is not
      --  available.
 
      function Line return String;
      --  Returns current line number without the leading space
 
      --------------
      -- Filename --
      --------------
 
      function Filename return String is
         File : constant String := AWK.File (Session);
      begin
         if File = "" then
            return "??";
         else
            return File;
         end if;
      end Filename;
 
      ----------
      -- Line --
      ----------
 
      function Line return String is
         L : constant String := Natural'Image (Session.Data.FNR);
      begin
         return L (2 .. L'Last);
      end Line;
 
   --  Start of processing for Raise_With_Info
 
   begin
      Exceptions.Raise_Exception
        (E,
         '[' & Filename & ':' & Line & "] " & Message);
      raise Constraint_Error; -- to please GNAT as this is a No_Return proc
   end Raise_With_Info;
 
   ---------------
   -- Read_Line --
   ---------------
 
   procedure Read_Line (Session : Session_Type) is
 
      function Read_Line return String;
      --  Read a line in the current file. This implementation is recursive
      --  and does not have a limitation on the line length.
 
      NR  : Natural renames Session.Data.NR;
      FNR : Natural renames Session.Data.FNR;
 
      ---------------
      -- Read_Line --
      ---------------
 
      function Read_Line return String is
         Buffer : String (1 .. 1_024);
         Last   : Natural;
 
      begin
         Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last);
 
         if Last = Buffer'Last then
            return Buffer & Read_Line;
         else
            return Buffer (1 .. Last);
         end if;
      end Read_Line;
 
   --  Start of processing for Read_Line
 
   begin
      if End_Of_File (Session) then
         Open_Next_File (Session);
         FNR := 0;
      end if;
 
      Session.Data.Current_Line := To_Unbounded_String (Read_Line);
 
      NR := NR + 1;
      FNR := FNR + 1;
   end Read_Line;
 
   --------------
   -- Register --
   --------------
 
   procedure Register
     (Field   : Count;
      Pattern : String;
      Action  : Action_Callback;
      Session : Session_Type)
   is
      Filters   : Pattern_Action_Table.Instance renames Session.Data.Filters;
      U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern);
 
   begin
      Pattern_Action_Table.Increment_Last (Filters);
 
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
        (Pattern => new Patterns.String_Pattern'(U_Pattern, Field),
         Action  => new Actions.Simple_Action'(Proc => Action));
   end Register;
 
   procedure Register
     (Field   : Count;
      Pattern : String;
      Action  : Action_Callback)
   is
   begin
      Register (Field, Pattern, Action, Cur_Session);
   end Register;
 
   procedure Register
     (Field   : Count;
      Pattern : GNAT.Regpat.Pattern_Matcher;
      Action  : Action_Callback;
      Session : Session_Type)
   is
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
 
      A_Pattern : constant Patterns.Pattern_Matcher_Access :=
                    new Regpat.Pattern_Matcher'(Pattern);
   begin
      Pattern_Action_Table.Increment_Last (Filters);
 
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
        (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
         Action  => new Actions.Simple_Action'(Proc => Action));
   end Register;
 
   procedure Register
     (Field   : Count;
      Pattern : GNAT.Regpat.Pattern_Matcher;
      Action  : Action_Callback)
   is
   begin
      Register (Field, Pattern, Action, Cur_Session);
   end Register;
 
   procedure Register
     (Field   : Count;
      Pattern : GNAT.Regpat.Pattern_Matcher;
      Action  : Match_Action_Callback;
      Session : Session_Type)
   is
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
 
      A_Pattern : constant Patterns.Pattern_Matcher_Access :=
                    new Regpat.Pattern_Matcher'(Pattern);
   begin
      Pattern_Action_Table.Increment_Last (Filters);
 
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
        (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
         Action  => new Actions.Match_Action'(Proc => Action));
   end Register;
 
   procedure Register
     (Field   : Count;
      Pattern : GNAT.Regpat.Pattern_Matcher;
      Action  : Match_Action_Callback)
   is
   begin
      Register (Field, Pattern, Action, Cur_Session);
   end Register;
 
   procedure Register
     (Pattern : Pattern_Callback;
      Action  : Action_Callback;
      Session : Session_Type)
   is
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
 
   begin
      Pattern_Action_Table.Increment_Last (Filters);
 
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
        (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern),
         Action  => new Actions.Simple_Action'(Proc => Action));
   end Register;
 
   procedure Register
     (Pattern : Pattern_Callback;
      Action  : Action_Callback)
   is
   begin
      Register (Pattern, Action, Cur_Session);
   end Register;
 
   procedure Register
     (Action  : Action_Callback;
      Session : Session_Type)
   is
   begin
      Register (Always_True'Access, Action, Session);
   end Register;
 
   procedure Register
     (Action  : Action_Callback)
   is
   begin
      Register (Action, Cur_Session);
   end Register;
 
   -----------------
   -- Set_Current --
   -----------------
 
   procedure Set_Current (Session : Session_Type) is
   begin
      Cur_Session.Data := Session.Data;
   end Set_Current;
 
   --------------------------
   -- Set_Field_Separators --
   --------------------------
 
   procedure Set_Field_Separators
     (Separators : String       := Default_Separators;
      Session    : Session_Type)
   is
   begin
      Free (Session.Data.Separators);
 
      Session.Data.Separators :=
        new Split.Separator'(Separators'Length, Separators);
 
      --  If there is a current line read, split it according to the new
      --  separators.
 
      if Session.Data.Current_Line /= Null_Unbounded_String then
         Split_Line (Session);
      end if;
   end Set_Field_Separators;
 
   procedure Set_Field_Separators
     (Separators : String       := Default_Separators)
   is
   begin
      Set_Field_Separators (Separators, Cur_Session);
   end Set_Field_Separators;
 
   ----------------------
   -- Set_Field_Widths --
   ----------------------
 
   procedure Set_Field_Widths
     (Field_Widths : Widths_Set;
      Session      : Session_Type)
   is
   begin
      Free (Session.Data.Separators);
 
      Session.Data.Separators :=
        new Split.Column'(Field_Widths'Length, Field_Widths);
 
      --  If there is a current line read, split it according to
      --  the new separators.
 
      if Session.Data.Current_Line /= Null_Unbounded_String then
         Split_Line (Session);
      end if;
   end Set_Field_Widths;
 
   procedure Set_Field_Widths
     (Field_Widths : Widths_Set)
   is
   begin
      Set_Field_Widths (Field_Widths, Cur_Session);
   end Set_Field_Widths;
 
   ----------------
   -- Split_Line --
   ----------------
 
   procedure Split_Line (Session : Session_Type) is
      Fields : Field_Table.Instance renames Session.Data.Fields;
   begin
      Field_Table.Init (Fields);
      Split.Current_Line (Session.Data.Separators.all, Session);
   end Split_Line;
 
   -------------
   -- Get_Def --
   -------------
 
   function Get_Def return Session_Data_Access is
   begin
      return Def_Session.Data;
   end Get_Def;
 
   -------------
   -- Set_Cur --
   -------------
 
   procedure Set_Cur is
   begin
      Cur_Session.Data := Def_Session.Data;
   end Set_Cur;
 
begin
   --  We have declared two sessions but both should share the same data.
   --  The current session must point to the default session as its initial
   --  value. So first we release the session data then we set current
   --  session data to point to default session data.
 
   Free (Cur_Session.Data);
   Cur_Session.Data := Def_Session.Data;
end GNAT.AWK;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-awk.adb] - Blame information for rev 729

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- G N A T . A W K --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2000-2011, AdaCore --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`with Ada.Exceptions;`
33			`with Ada.Text_IO;`
34			`with Ada.Strings.Unbounded;`
35			`with Ada.Strings.Fixed;`
36			`with Ada.Strings.Maps;`
37			`with Ada.Unchecked_Deallocation;`
38
39			`with GNAT.Directory_Operations;`
40			`with GNAT.Dynamic_Tables;`