Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              G N A T . A W K                             --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--                     Copyright (C) 2000-2010, 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 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,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, 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 Ada_95;

--  This is needed because the pragmas Warnings (Off) in Current_Session and

--  Default_Session (see below) do not work when compiling clients of this

--  package that instantiate generic units herein.

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 Session_Type is

   begin

      pragma Warnings (Off);

      return Cur_Session;

      --  ???The above return statement violates the Ada 2005 rule forbidding

      --  copying of limited objects (see RM-7.5(2.8/2)). When compiled with

      --  -gnatg, the compiler gives a warning instead of an error, so we can

      --  turn it off.

      pragma Warnings (On);

   end Current_Session;

   ---------------------

   -- Default_Session --

   ---------------------

   function Default_Session return Session_Type is

   begin

      pragma Warnings (Off);

      return Def_Session;

      --  ???The above return statement violates the Ada 2005 rule forbidding

      --  copying of limited objects (see RM-7.5(2.8/2)). When compiled with

      --  -gnatg, the compiler gives a warning instead of an error, so we can

      --  turn it off.

      pragma Warnings (On);

   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