-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2005 AdaCore --
+-- 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- --
-- --
------------------------------------------------------------------------------
-pragma Style_Checks (All_Checks);
--- Turn off alpha ordering check for subprograms, since we cannot
--- Put Finalize and Initialize in alpha order (see comments).
+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;
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 --
----------------
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 --
----------------
-- Session Variables --
-----------------------
- -- These must come after the body of Initialize, since they make
- -- implicit calls to Initialize at elaboration time.
-
Def_Session : Session_Type;
Cur_Session : Session_Type;
- --------------
- -- Finalize --
- --------------
-
- -- Note: Finalize must come after Initialize and the definition
- -- of the Def_Session and Cur_Session variables, since it references
- -- the latter.
-
- 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 /= Def_Session.Data then
- Free (Session.Data);
-
- -- Since we have closed the current session, set it to point now to
- -- the default session.
-
- Cur_Session.Data := Def_Session.Data;
- end if;
- end Finalize;
-
----------------------
-- Private Services --
----------------------
-- A function that always returns True
function Apply_Filters
- (Session : Session_Type := Current_Session) return Boolean;
+ (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 := Current_Session);
+ (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 Add_File
(Filename : String;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
Files : File_Table.Instance renames Session.Data.Files;
end if;
end Add_File;
+ procedure Add_File
+ (Filename : String)
+ is
+
+ begin
+ Add_File (Filename, Cur_Session);
+ end Add_File;
+
---------------
-- Add_Files --
---------------
(Directory : String;
Filenames : String;
Number_Of_Files_Added : out Natural;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
use Directory_Operations;
when others =>
Raise_With_Info
(File_Error'Identity,
- "Error scaning directory " & Directory
+ "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 Apply_Filters
- (Session : Session_Type := Current_Session) return Boolean
+ (Session : Session_Type) return Boolean
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
Results : Boolean := False;
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;
---------------------
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;
--------------------
function Discrete_Field
(Rank : Count;
- Session : Session_Type := Current_Session) return Discrete
+ 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 := Current_Session) return Boolean
+ (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 := Current_Session) return Boolean
+ (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 := Current_Session) return String
+ Session : Session_Type) return String
is
Fields : Field_Table.Instance renames Session.Data.Fields;
end Field;
function Field
+ (Rank : Count) return String
+ is
+ begin
+ return Field (Rank, Cur_Session);
+ end Field;
+
+ function Field
(Rank : Count;
- Session : Session_Type := Current_Session) return Integer
+ Session : Session_Type) return Integer
is
begin
return Integer'Value (Field (Rank, 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 := Current_Session) return Float
+ Session : Session_Type) return Float
is
begin
return Float'Value (Field (Rank, Session));
Session);
end Field;
+ function Field
+ (Rank : Count) return Float
+ is
+ begin
+ return Field (Rank, Cur_Session);
+ end Field;
+
----------
-- File --
----------
function File
- (Session : Session_Type := Current_Session) return String
+ (Session : Session_Type) return String
is
Files : File_Table.Instance renames Session.Data.Files;
end if;
end File;
+ function File
+ return String
+ is
+ begin
+ return File (Cur_Session);
+ end File;
+
--------------------
-- For_Every_Line --
--------------------
(Separators : String := Use_Current;
Filename : String := Use_Current;
Callbacks : Callback_Mode := None;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
Quit : Boolean;
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 := Current_Session)
+ Session : Session_Type)
is
Filter_Active : Boolean;
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 := Current_Session) return Count
+ (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 := Current_Session) return Count
+ (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 := Current_Session) return Natural
+ (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 := Current_Session) return Count
+ (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 := Current_Session)
+ Session : Session_Type)
is
begin
if Text_IO.Is_Open (Session.Data.Current_File) then
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 := Current_Session)
+ (Session : Session_Type)
is
Files : File_Table.Instance renames Session.Data.Files;
procedure Parse
(Separators : String := Use_Current;
Filename : String := Use_Current;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
Filter_Active : Boolean;
pragma Unreferenced (Filter_Active);
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 --
---------------------
(Field : Count;
Pattern : String;
Action : Action_Callback;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern);
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 := Current_Session)
+ Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
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 := Current_Session)
+ Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
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 := Current_Session)
+ Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
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 := Current_Session)
+ 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_Field_Separators
(Separators : String := Default_Separators;
- Session : Session_Type := Current_Session)
+ Session : Session_Type)
is
begin
Free (Session.Data.Separators);
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 := Current_Session)
+ Session : Session_Type)
is
begin
Free (Session.Data.Separators);
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 --
----------------
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
OSDN Git Service
