diff options
author | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
---|---|---|
committer | Ben Cheng <bccheng@google.com> | 2014-03-25 22:37:19 -0700 |
commit | 1bc5aee63eb72b341f506ad058502cd0361f0d10 (patch) | |
tree | c607e8252f3405424ff15bc2d00aa38dadbb2518 /gcc-4.9/gcc/ada/g-awk.adb | |
parent | 283a0bf58fcf333c58a2a92c3ebbc41fb9eb1fdb (diff) | |
download | toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.gz toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.tar.bz2 toolchain_gcc-1bc5aee63eb72b341f506ad058502cd0361f0d10.zip |
Initial checkin of GCC 4.9.0 from trunk (r208799).
Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba
Diffstat (limited to 'gcc-4.9/gcc/ada/g-awk.adb')
-rw-r--r-- | gcc-4.9/gcc/ada/g-awk.adb | 1491 |
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; |