aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/g-awk.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/g-awk.adb')
-rw-r--r--gcc-4.9/gcc/ada/g-awk.adb1491
1 files changed, 1491 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/g-awk.adb b/gcc-4.9/gcc/ada/g-awk.adb
new file mode 100644
index 000000000..f2c934c2f
--- /dev/null
+++ b/gcc-4.9/gcc/ada/g-awk.adb
@@ -0,0 +1,1491 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;