diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-awk.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/g-awk.adb | 1510 |
1 files changed, 0 insertions, 1510 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-awk.adb b/gcc-4.4.3/gcc/ada/g-awk.adb deleted file mode 100644 index 0dee657b1..000000000 --- a/gcc-4.4.3/gcc/ada/g-awk.adb +++ /dev/null @@ -1,1510 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A W K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2008, 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 - 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; - - Start : Natural; - Stop : Natural; - - Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators); - - 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 separators - - Free (Session.Data.Separators); - - -- 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 - 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; |