PR target/16201
[official-gcc.git] / gcc / ada / g-awk.adb
blobcece7e6de480bd2eecfd7dc945078360df415c54
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . A W K --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 pragma Style_Checks (All_Checks);
35 -- Turn off alpha ordering check for subprograms, since we cannot
36 -- Put Finalize and Initialize in alpha order (see comments).
38 with Ada.Exceptions;
39 with Ada.Text_IO;
40 with Ada.Strings.Unbounded;
41 with Ada.Strings.Fixed;
42 with Ada.Strings.Maps;
43 with Ada.Unchecked_Deallocation;
45 with GNAT.Directory_Operations;
46 with GNAT.Dynamic_Tables;
47 with GNAT.OS_Lib;
49 package body GNAT.AWK is
51 use Ada;
52 use Ada.Strings.Unbounded;
54 ----------------
55 -- Split mode --
56 ----------------
58 package Split is
60 type Mode is abstract tagged null record;
61 -- This is the main type which is declared abstract. This type must be
62 -- derived for each split style.
64 type Mode_Access is access Mode'Class;
66 procedure Current_Line (S : Mode; Session : Session_Type)
67 is abstract;
68 -- Split Session's current line using split mode.
70 ------------------------
71 -- Split on separator --
72 ------------------------
74 type Separator (Size : Positive) is new Mode with record
75 Separators : String (1 .. Size);
76 end record;
78 procedure Current_Line
79 (S : Separator;
80 Session : Session_Type);
82 ---------------------
83 -- Split on column --
84 ---------------------
86 type Column (Size : Positive) is new Mode with record
87 Columns : Widths_Set (1 .. Size);
88 end record;
90 procedure Current_Line (S : Column; Session : Session_Type);
92 end Split;
94 procedure Free is new Unchecked_Deallocation
95 (Split.Mode'Class, Split.Mode_Access);
97 ----------------
98 -- File_Table --
99 ----------------
101 type AWK_File is access String;
103 package File_Table is
104 new Dynamic_Tables (AWK_File, Natural, 1, 5, 50);
105 -- List of filename associated with a Session.
107 procedure Free is new Unchecked_Deallocation (String, AWK_File);
109 -----------------
110 -- Field_Table --
111 -----------------
113 type Field_Slice is record
114 First : Positive;
115 Last : Natural;
116 end record;
117 -- This is a field slice (First .. Last) in session's current line.
119 package Field_Table is
120 new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100);
121 -- List of fields for the current line.
123 --------------
124 -- Patterns --
125 --------------
127 -- Define all patterns style : exact string, regular expression, boolean
128 -- function.
130 package Patterns is
132 type Pattern is abstract tagged null record;
133 -- This is the main type which is declared abstract. This type must be
134 -- derived for each patterns style.
136 type Pattern_Access is access Pattern'Class;
138 function Match
139 (P : Pattern;
140 Session : Session_Type)
141 return Boolean
142 is abstract;
143 -- Returns True if P match for the current session and False otherwise.
145 procedure Release (P : in out Pattern);
146 -- Release memory used by the pattern structure.
148 --------------------------
149 -- Exact string pattern --
150 --------------------------
152 type String_Pattern is new Pattern with record
153 Str : Unbounded_String;
154 Rank : Count;
155 end record;
157 function Match
158 (P : String_Pattern;
159 Session : Session_Type)
160 return Boolean;
162 --------------------------------
163 -- Regular expression pattern --
164 --------------------------------
166 type Pattern_Matcher_Access is access Regpat.Pattern_Matcher;
168 type Regexp_Pattern is new Pattern with record
169 Regx : Pattern_Matcher_Access;
170 Rank : Count;
171 end record;
173 function Match
174 (P : Regexp_Pattern;
175 Session : Session_Type)
176 return Boolean;
178 procedure Release (P : in out Regexp_Pattern);
180 ------------------------------
181 -- Boolean function pattern --
182 ------------------------------
184 type Callback_Pattern is new Pattern with record
185 Pattern : Pattern_Callback;
186 end record;
188 function Match
189 (P : Callback_Pattern;
190 Session : Session_Type)
191 return Boolean;
193 end Patterns;
195 procedure Free is new Unchecked_Deallocation
196 (Patterns.Pattern'Class, Patterns.Pattern_Access);
198 -------------
199 -- Actions --
200 -------------
202 -- Define all action style : simple call, call with matches
204 package Actions is
206 type Action is abstract tagged null record;
207 -- This is the main type which is declared abstract. This type must be
208 -- derived for each action style.
210 type Action_Access is access Action'Class;
212 procedure Call
213 (A : Action;
214 Session : Session_Type)
215 is abstract;
216 -- Call action A as required.
218 -------------------
219 -- Simple action --
220 -------------------
222 type Simple_Action is new Action with record
223 Proc : Action_Callback;
224 end record;
226 procedure Call
227 (A : Simple_Action;
228 Session : Session_Type);
230 -------------------------
231 -- Action with matches --
232 -------------------------
234 type Match_Action is new Action with record
235 Proc : Match_Action_Callback;
236 end record;
238 procedure Call
239 (A : Match_Action;
240 Session : Session_Type);
242 end Actions;
244 procedure Free is new Unchecked_Deallocation
245 (Actions.Action'Class, Actions.Action_Access);
247 --------------------------
248 -- Pattern/Action table --
249 --------------------------
251 type Pattern_Action is record
252 Pattern : Patterns.Pattern_Access; -- If Pattern is True
253 Action : Actions.Action_Access; -- Action will be called
254 end record;
256 package Pattern_Action_Table is
257 new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50);
259 ------------------
260 -- Session Data --
261 ------------------
263 type Session_Data is record
264 Current_File : Text_IO.File_Type;
265 Current_Line : Unbounded_String;
266 Separators : Split.Mode_Access;
267 Files : File_Table.Instance;
268 File_Index : Natural := 0;
269 Fields : Field_Table.Instance;
270 Filters : Pattern_Action_Table.Instance;
271 NR : Natural := 0;
272 FNR : Natural := 0;
273 Matches : Regpat.Match_Array (0 .. 100);
274 -- latest matches for the regexp pattern
275 end record;
277 procedure Free is
278 new Unchecked_Deallocation (Session_Data, Session_Data_Access);
280 ----------------
281 -- Initialize --
282 ----------------
284 procedure Initialize (Session : in out Session_Type) is
285 begin
286 Session.Data := new Session_Data;
288 -- Initialize separators
290 Session.Data.Separators :=
291 new Split.Separator'(Default_Separators'Length, Default_Separators);
293 -- Initialize all tables
295 File_Table.Init (Session.Data.Files);
296 Field_Table.Init (Session.Data.Fields);
297 Pattern_Action_Table.Init (Session.Data.Filters);
298 end Initialize;
300 -----------------------
301 -- Session Variables --
302 -----------------------
304 -- These must come after the body of Initialize, since they make
305 -- implicit calls to Initialize at elaboration time.
307 Def_Session : Session_Type;
308 Cur_Session : Session_Type;
310 --------------
311 -- Finalize --
312 --------------
314 -- Note: Finalize must come after Initialize and the definition
315 -- of the Def_Session and Cur_Session variables, since it references
316 -- the latter.
318 procedure Finalize (Session : in out Session_Type) is
319 begin
320 -- We release the session data only if it is not the default session.
322 if Session.Data /= Def_Session.Data then
323 Free (Session.Data);
325 -- Since we have closed the current session, set it to point
326 -- now to the default session.
328 Cur_Session.Data := Def_Session.Data;
329 end if;
330 end Finalize;
332 ----------------------
333 -- Private Services --
334 ----------------------
336 function Always_True return Boolean;
337 -- A function that always returns True.
339 function Apply_Filters
340 (Session : Session_Type := Current_Session)
341 return Boolean;
342 -- Apply any filters for which the Pattern is True for Session. It returns
343 -- True if a least one filters has been applied (i.e. associated action
344 -- callback has been called).
346 procedure Open_Next_File
347 (Session : Session_Type := Current_Session);
348 pragma Inline (Open_Next_File);
349 -- Open next file for Session closing current file if needed. It raises
350 -- End_Error if there is no more file in the table.
352 procedure Raise_With_Info
353 (E : Exceptions.Exception_Id;
354 Message : String;
355 Session : Session_Type);
356 pragma No_Return (Raise_With_Info);
357 -- Raises exception E with the message prepended with the current line
358 -- number and the filename if possible.
360 procedure Read_Line (Session : Session_Type);
361 -- Read a line for the Session and set Current_Line.
363 procedure Split_Line (Session : Session_Type);
364 -- Split session's Current_Line according to the session separators and
365 -- set the Fields table. This procedure can be called at any time.
367 ----------------------
368 -- Private Packages --
369 ----------------------
371 -------------
372 -- Actions --
373 -------------
375 package body Actions is
377 ----------
378 -- Call --
379 ----------
381 procedure Call
382 (A : Simple_Action;
383 Session : Session_Type)
385 pragma Unreferenced (Session);
387 begin
388 A.Proc.all;
389 end Call;
391 ----------
392 -- Call --
393 ----------
395 procedure Call
396 (A : Match_Action;
397 Session : Session_Type)
399 begin
400 A.Proc (Session.Data.Matches);
401 end Call;
403 end Actions;
405 --------------
406 -- Patterns --
407 --------------
409 package body Patterns is
411 -----------
412 -- Match --
413 -----------
415 function Match
416 (P : String_Pattern;
417 Session : Session_Type)
418 return Boolean
420 begin
421 return P.Str = Field (P.Rank, Session);
422 end Match;
424 -----------
425 -- Match --
426 -----------
428 function Match
429 (P : Regexp_Pattern;
430 Session : Session_Type)
431 return Boolean
433 use type Regpat.Match_Location;
435 begin
436 Regpat.Match
437 (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches);
438 return Session.Data.Matches (0) /= Regpat.No_Match;
439 end Match;
441 -----------
442 -- Match --
443 -----------
445 function Match
446 (P : Callback_Pattern;
447 Session : Session_Type)
448 return Boolean
450 pragma Unreferenced (Session);
452 begin
453 return P.Pattern.all;
454 end Match;
456 -------------
457 -- Release --
458 -------------
460 procedure Release (P : in out Pattern) is
461 pragma Unreferenced (P);
463 begin
464 null;
465 end Release;
467 -------------
468 -- Release --
469 -------------
471 procedure Release (P : in out Regexp_Pattern) is
472 procedure Free is new Unchecked_Deallocation
473 (Regpat.Pattern_Matcher, Pattern_Matcher_Access);
475 begin
476 Free (P.Regx);
477 end Release;
479 end Patterns;
481 -----------
482 -- Split --
483 -----------
485 package body Split is
487 use Ada.Strings;
489 ------------------
490 -- Current_Line --
491 ------------------
493 procedure Current_Line (S : Separator; Session : Session_Type) is
494 Line : constant String := To_String (Session.Data.Current_Line);
495 Fields : Field_Table.Instance renames Session.Data.Fields;
497 Start : Natural;
498 Stop : Natural;
500 Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators);
502 begin
503 -- First field start here
505 Start := Line'First;
507 -- Record the first field start position which is the first character
508 -- in the line.
510 Field_Table.Increment_Last (Fields);
511 Fields.Table (Field_Table.Last (Fields)).First := Start;
513 loop
514 -- Look for next separator
516 Stop := Fixed.Index
517 (Source => Line (Start .. Line'Last),
518 Set => Seps);
520 exit when Stop = 0;
522 Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1;
524 -- If separators are set to the default (space and tab) we skip
525 -- all spaces and tabs following current field.
527 if S.Separators = Default_Separators then
528 Start := Fixed.Index
529 (Line (Stop + 1 .. Line'Last),
530 Maps.To_Set (Default_Separators),
531 Outside,
532 Strings.Forward);
534 if Start = 0 then
535 Start := Stop + 1;
536 end if;
537 else
538 Start := Stop + 1;
539 end if;
541 -- Record in the field table the start of this new field
543 Field_Table.Increment_Last (Fields);
544 Fields.Table (Field_Table.Last (Fields)).First := Start;
546 end loop;
548 Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
549 end Current_Line;
551 ------------------
552 -- Current_Line --
553 ------------------
555 procedure Current_Line (S : Column; Session : Session_Type) is
556 Line : constant String := To_String (Session.Data.Current_Line);
557 Fields : Field_Table.Instance renames Session.Data.Fields;
558 Start : Positive := Line'First;
560 begin
561 -- Record the first field start position which is the first character
562 -- in the line.
564 for C in 1 .. S.Columns'Length loop
566 Field_Table.Increment_Last (Fields);
568 Fields.Table (Field_Table.Last (Fields)).First := Start;
570 Start := Start + S.Columns (C);
572 Fields.Table (Field_Table.Last (Fields)).Last := Start - 1;
574 end loop;
576 -- If there is some remaining character on the line, add them in a
577 -- new field.
579 if Start - 1 < Line'Length then
581 Field_Table.Increment_Last (Fields);
583 Fields.Table (Field_Table.Last (Fields)).First := Start;
585 Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
586 end if;
587 end Current_Line;
589 end Split;
591 --------------
592 -- Add_File --
593 --------------
595 procedure Add_File
596 (Filename : String;
597 Session : Session_Type := Current_Session)
599 Files : File_Table.Instance renames Session.Data.Files;
601 begin
602 if OS_Lib.Is_Regular_File (Filename) then
603 File_Table.Increment_Last (Files);
604 Files.Table (File_Table.Last (Files)) := new String'(Filename);
605 else
606 Raise_With_Info
607 (File_Error'Identity,
608 "File " & Filename & " not found.",
609 Session);
610 end if;
611 end Add_File;
613 ---------------
614 -- Add_Files --
615 ---------------
617 procedure Add_Files
618 (Directory : String;
619 Filenames : String;
620 Number_Of_Files_Added : out Natural;
621 Session : Session_Type := Current_Session)
623 use Directory_Operations;
625 Dir : Dir_Type;
626 Filename : String (1 .. 200);
627 Last : Natural;
629 begin
630 Number_Of_Files_Added := 0;
632 Open (Dir, Directory);
634 loop
635 Read (Dir, Filename, Last);
636 exit when Last = 0;
638 Add_File (Filename (1 .. Last), Session);
639 Number_Of_Files_Added := Number_Of_Files_Added + 1;
640 end loop;
642 Close (Dir);
644 exception
645 when others =>
646 Raise_With_Info
647 (File_Error'Identity,
648 "Error scaning directory " & Directory
649 & " for files " & Filenames & '.',
650 Session);
651 end Add_Files;
653 -----------------
654 -- Always_True --
655 -----------------
657 function Always_True return Boolean is
658 begin
659 return True;
660 end Always_True;
662 -------------------
663 -- Apply_Filters --
664 -------------------
666 function Apply_Filters
667 (Session : Session_Type := Current_Session)
668 return Boolean
670 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
671 Results : Boolean := False;
673 begin
674 -- Iterate through the filters table, if pattern match call action.
676 for F in 1 .. Pattern_Action_Table.Last (Filters) loop
677 if Patterns.Match (Filters.Table (F).Pattern.all, Session) then
678 Results := True;
679 Actions.Call (Filters.Table (F).Action.all, Session);
680 end if;
681 end loop;
683 return Results;
684 end Apply_Filters;
686 -----------
687 -- Close --
688 -----------
690 procedure Close (Session : Session_Type) is
691 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
692 Files : File_Table.Instance renames Session.Data.Files;
694 begin
695 -- Close current file if needed
697 if Text_IO.Is_Open (Session.Data.Current_File) then
698 Text_IO.Close (Session.Data.Current_File);
699 end if;
701 -- Release separators
703 Free (Session.Data.Separators);
705 -- Release Filters table
707 for F in 1 .. Pattern_Action_Table.Last (Filters) loop
708 Patterns.Release (Filters.Table (F).Pattern.all);
709 Free (Filters.Table (F).Pattern);
710 Free (Filters.Table (F).Action);
711 end loop;
713 for F in 1 .. File_Table.Last (Files) loop
714 Free (Files.Table (F));
715 end loop;
717 File_Table.Set_Last (Session.Data.Files, 0);
718 Field_Table.Set_Last (Session.Data.Fields, 0);
719 Pattern_Action_Table.Set_Last (Session.Data.Filters, 0);
721 Session.Data.NR := 0;
722 Session.Data.FNR := 0;
723 Session.Data.File_Index := 0;
724 Session.Data.Current_Line := Null_Unbounded_String;
725 end Close;
727 ---------------------
728 -- Current_Session --
729 ---------------------
731 function Current_Session return Session_Type is
732 begin
733 return Cur_Session;
734 end Current_Session;
736 ---------------------
737 -- Default_Session --
738 ---------------------
740 function Default_Session return Session_Type is
741 begin
742 return Def_Session;
743 end Default_Session;
745 --------------------
746 -- Discrete_Field --
747 --------------------
749 function Discrete_Field
750 (Rank : Count;
751 Session : Session_Type := Current_Session)
752 return Discrete
754 begin
755 return Discrete'Value (Field (Rank, Session));
756 end Discrete_Field;
758 -----------------
759 -- End_Of_Data --
760 -----------------
762 function End_Of_Data
763 (Session : Session_Type := Current_Session)
764 return Boolean
766 begin
767 return Session.Data.File_Index = File_Table.Last (Session.Data.Files)
768 and then End_Of_File (Session);
769 end End_Of_Data;
771 -----------------
772 -- End_Of_File --
773 -----------------
775 function End_Of_File
776 (Session : Session_Type := Current_Session)
777 return Boolean
779 begin
780 return Text_IO.End_Of_File (Session.Data.Current_File);
781 end End_Of_File;
783 -----------
784 -- Field --
785 -----------
787 function Field
788 (Rank : Count;
789 Session : Session_Type := Current_Session)
790 return String
792 Fields : Field_Table.Instance renames Session.Data.Fields;
794 begin
795 if Rank > Number_Of_Fields (Session) then
796 Raise_With_Info
797 (Field_Error'Identity,
798 "Field number" & Count'Image (Rank) & " does not exist.",
799 Session);
801 elsif Rank = 0 then
803 -- Returns the whole line, this is what $0 does under Session_Type.
805 return To_String (Session.Data.Current_Line);
807 else
808 return Slice (Session.Data.Current_Line,
809 Fields.Table (Positive (Rank)).First,
810 Fields.Table (Positive (Rank)).Last);
811 end if;
812 end Field;
814 function Field
815 (Rank : Count;
816 Session : Session_Type := Current_Session)
817 return Integer
819 begin
820 return Integer'Value (Field (Rank, Session));
822 exception
823 when Constraint_Error =>
824 Raise_With_Info
825 (Field_Error'Identity,
826 "Field number" & Count'Image (Rank)
827 & " cannot be converted to an integer.",
828 Session);
829 end Field;
831 function Field
832 (Rank : Count;
833 Session : Session_Type := Current_Session)
834 return Float
836 begin
837 return Float'Value (Field (Rank, Session));
839 exception
840 when Constraint_Error =>
841 Raise_With_Info
842 (Field_Error'Identity,
843 "Field number" & Count'Image (Rank)
844 & " cannot be converted to a float.",
845 Session);
846 end Field;
848 ----------
849 -- File --
850 ----------
852 function File
853 (Session : Session_Type := Current_Session)
854 return String
856 Files : File_Table.Instance renames Session.Data.Files;
858 begin
859 if Session.Data.File_Index = 0 then
860 return "??";
861 else
862 return Files.Table (Session.Data.File_Index).all;
863 end if;
864 end File;
866 --------------------
867 -- For_Every_Line --
868 --------------------
870 procedure For_Every_Line
871 (Separators : String := Use_Current;
872 Filename : String := Use_Current;
873 Callbacks : Callback_Mode := None;
874 Session : Session_Type := Current_Session)
876 Quit : Boolean;
878 begin
879 Open (Separators, Filename, Session);
881 while not End_Of_Data (Session) loop
882 Read_Line (Session);
883 Split_Line (Session);
885 if Callbacks in Only .. Pass_Through then
886 declare
887 Discard : Boolean;
888 pragma Unreferenced (Discard);
889 begin
890 Discard := Apply_Filters (Session);
891 end;
892 end if;
894 if Callbacks /= Only then
895 Quit := False;
896 Action (Quit);
897 exit when Quit;
898 end if;
899 end loop;
901 Close (Session);
902 end For_Every_Line;
904 --------------
905 -- Get_Line --
906 --------------
908 procedure Get_Line
909 (Callbacks : Callback_Mode := None;
910 Session : Session_Type := Current_Session)
912 Filter_Active : Boolean;
914 begin
915 if not Text_IO.Is_Open (Session.Data.Current_File) then
916 raise File_Error;
917 end if;
919 loop
920 Read_Line (Session);
921 Split_Line (Session);
923 case Callbacks is
925 when None =>
926 exit;
928 when Only =>
929 Filter_Active := Apply_Filters (Session);
930 exit when not Filter_Active;
932 when Pass_Through =>
933 Filter_Active := Apply_Filters (Session);
934 exit;
936 end case;
937 end loop;
938 end Get_Line;
940 ----------------------
941 -- Number_Of_Fields --
942 ----------------------
944 function Number_Of_Fields
945 (Session : Session_Type := Current_Session)
946 return Count
948 begin
949 return Count (Field_Table.Last (Session.Data.Fields));
950 end Number_Of_Fields;
952 --------------------------
953 -- Number_Of_File_Lines --
954 --------------------------
956 function Number_Of_File_Lines
957 (Session : Session_Type := Current_Session)
958 return Count
960 begin
961 return Count (Session.Data.FNR);
962 end Number_Of_File_Lines;
964 ---------------------
965 -- Number_Of_Files --
966 ---------------------
968 function Number_Of_Files
969 (Session : Session_Type := Current_Session)
970 return Natural
972 Files : File_Table.Instance renames Session.Data.Files;
974 begin
975 return File_Table.Last (Files);
976 end Number_Of_Files;
978 ---------------------
979 -- Number_Of_Lines --
980 ---------------------
982 function Number_Of_Lines
983 (Session : Session_Type := Current_Session)
984 return Count
986 begin
987 return Count (Session.Data.NR);
988 end Number_Of_Lines;
990 ----------
991 -- Open --
992 ----------
994 procedure Open
995 (Separators : String := Use_Current;
996 Filename : String := Use_Current;
997 Session : Session_Type := Current_Session)
999 begin
1000 if Text_IO.Is_Open (Session.Data.Current_File) then
1001 raise Session_Error;
1002 end if;
1004 if Filename /= Use_Current then
1005 File_Table.Init (Session.Data.Files);
1006 Add_File (Filename, Session);
1007 end if;
1009 if Separators /= Use_Current then
1010 Set_Field_Separators (Separators, Session);
1011 end if;
1013 Open_Next_File (Session);
1015 exception
1016 when End_Error =>
1017 raise File_Error;
1018 end Open;
1020 --------------------
1021 -- Open_Next_File --
1022 --------------------
1024 procedure Open_Next_File
1025 (Session : Session_Type := Current_Session)
1027 Files : File_Table.Instance renames Session.Data.Files;
1029 begin
1030 if Text_IO.Is_Open (Session.Data.Current_File) then
1031 Text_IO.Close (Session.Data.Current_File);
1032 end if;
1034 Session.Data.File_Index := Session.Data.File_Index + 1;
1036 -- If there are no mores file in the table, raise End_Error
1038 if Session.Data.File_Index > File_Table.Last (Files) then
1039 raise End_Error;
1040 end if;
1042 Text_IO.Open
1043 (File => Session.Data.Current_File,
1044 Name => Files.Table (Session.Data.File_Index).all,
1045 Mode => Text_IO.In_File);
1046 end Open_Next_File;
1048 -----------
1049 -- Parse --
1050 -----------
1052 procedure Parse
1053 (Separators : String := Use_Current;
1054 Filename : String := Use_Current;
1055 Session : Session_Type := Current_Session)
1057 Filter_Active : Boolean;
1058 pragma Unreferenced (Filter_Active);
1060 begin
1061 Open (Separators, Filename, Session);
1063 while not End_Of_Data (Session) loop
1064 Get_Line (None, Session);
1065 Filter_Active := Apply_Filters (Session);
1066 end loop;
1068 Close (Session);
1069 end Parse;
1071 ---------------------
1072 -- Raise_With_Info --
1073 ---------------------
1075 procedure Raise_With_Info
1076 (E : Exceptions.Exception_Id;
1077 Message : String;
1078 Session : Session_Type)
1080 function Filename return String;
1081 -- Returns current filename and "??" if the informations is not
1082 -- available.
1084 function Line return String;
1085 -- Returns current line number without the leading space
1087 --------------
1088 -- Filename --
1089 --------------
1091 function Filename return String is
1092 File : constant String := AWK.File (Session);
1094 begin
1095 if File = "" then
1096 return "??";
1097 else
1098 return File;
1099 end if;
1100 end Filename;
1102 ----------
1103 -- Line --
1104 ----------
1106 function Line return String is
1107 L : constant String := Natural'Image (Session.Data.FNR);
1109 begin
1110 return L (2 .. L'Last);
1111 end Line;
1113 -- Start of processing for Raise_With_Info
1115 begin
1116 Exceptions.Raise_Exception
1118 '[' & Filename & ':' & Line & "] " & Message);
1119 raise Constraint_Error; -- to please GNAT as this is a No_Return proc
1120 end Raise_With_Info;
1122 ---------------
1123 -- Read_Line --
1124 ---------------
1126 procedure Read_Line (Session : Session_Type) is
1128 function Read_Line return String;
1129 -- Read a line in the current file. This implementation is recursive
1130 -- and does not have a limitation on the line length.
1132 NR : Natural renames Session.Data.NR;
1133 FNR : Natural renames Session.Data.FNR;
1135 function Read_Line return String is
1136 Buffer : String (1 .. 1_024);
1137 Last : Natural;
1139 begin
1140 Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last);
1142 if Last = Buffer'Last then
1143 return Buffer & Read_Line;
1144 else
1145 return Buffer (1 .. Last);
1146 end if;
1147 end Read_Line;
1149 -- Start of processing for Read_Line
1151 begin
1152 if End_Of_File (Session) then
1153 Open_Next_File (Session);
1154 FNR := 0;
1155 end if;
1157 Session.Data.Current_Line := To_Unbounded_String (Read_Line);
1159 NR := NR + 1;
1160 FNR := FNR + 1;
1161 end Read_Line;
1163 --------------
1164 -- Register --
1165 --------------
1167 procedure Register
1168 (Field : Count;
1169 Pattern : String;
1170 Action : Action_Callback;
1171 Session : Session_Type := Current_Session)
1173 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1174 U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern);
1176 begin
1177 Pattern_Action_Table.Increment_Last (Filters);
1179 Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1180 (Pattern => new Patterns.String_Pattern'(U_Pattern, Field),
1181 Action => new Actions.Simple_Action'(Proc => Action));
1182 end Register;
1184 procedure Register
1185 (Field : Count;
1186 Pattern : GNAT.Regpat.Pattern_Matcher;
1187 Action : Action_Callback;
1188 Session : Session_Type := Current_Session)
1190 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1192 A_Pattern : constant Patterns.Pattern_Matcher_Access :=
1193 new Regpat.Pattern_Matcher'(Pattern);
1194 begin
1195 Pattern_Action_Table.Increment_Last (Filters);
1197 Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1198 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
1199 Action => new Actions.Simple_Action'(Proc => Action));
1200 end Register;
1202 procedure Register
1203 (Field : Count;
1204 Pattern : GNAT.Regpat.Pattern_Matcher;
1205 Action : Match_Action_Callback;
1206 Session : Session_Type := Current_Session)
1208 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1210 A_Pattern : constant Patterns.Pattern_Matcher_Access :=
1211 new Regpat.Pattern_Matcher'(Pattern);
1212 begin
1213 Pattern_Action_Table.Increment_Last (Filters);
1215 Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1216 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
1217 Action => new Actions.Match_Action'(Proc => Action));
1218 end Register;
1220 procedure Register
1221 (Pattern : Pattern_Callback;
1222 Action : Action_Callback;
1223 Session : Session_Type := Current_Session)
1225 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1227 begin
1228 Pattern_Action_Table.Increment_Last (Filters);
1230 Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1231 (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern),
1232 Action => new Actions.Simple_Action'(Proc => Action));
1233 end Register;
1235 procedure Register
1236 (Action : Action_Callback;
1237 Session : Session_Type := Current_Session)
1239 begin
1240 Register (Always_True'Access, Action, Session);
1241 end Register;
1243 -----------------
1244 -- Set_Current --
1245 -----------------
1247 procedure Set_Current (Session : Session_Type) is
1248 begin
1249 Cur_Session.Data := Session.Data;
1250 end Set_Current;
1252 --------------------------
1253 -- Set_Field_Separators --
1254 --------------------------
1256 procedure Set_Field_Separators
1257 (Separators : String := Default_Separators;
1258 Session : Session_Type := Current_Session)
1260 begin
1261 Free (Session.Data.Separators);
1263 Session.Data.Separators :=
1264 new Split.Separator'(Separators'Length, Separators);
1266 -- If there is a current line read, split it according to the new
1267 -- separators.
1269 if Session.Data.Current_Line /= Null_Unbounded_String then
1270 Split_Line (Session);
1271 end if;
1272 end Set_Field_Separators;
1274 ----------------------
1275 -- Set_Field_Widths --
1276 ----------------------
1278 procedure Set_Field_Widths
1279 (Field_Widths : Widths_Set;
1280 Session : Session_Type := Current_Session) is
1282 begin
1283 Free (Session.Data.Separators);
1285 Session.Data.Separators :=
1286 new Split.Column'(Field_Widths'Length, Field_Widths);
1288 -- If there is a current line read, split it according to
1289 -- the new separators.
1291 if Session.Data.Current_Line /= Null_Unbounded_String then
1292 Split_Line (Session);
1293 end if;
1294 end Set_Field_Widths;
1296 ----------------
1297 -- Split_Line --
1298 ----------------
1300 procedure Split_Line (Session : Session_Type) is
1301 Fields : Field_Table.Instance renames Session.Data.Fields;
1303 begin
1304 Field_Table.Init (Fields);
1306 Split.Current_Line (Session.Data.Separators.all, Session);
1307 end Split_Line;
1309 begin
1310 -- We have declared two sessions but both should share the same data.
1311 -- The current session must point to the default session as its initial
1312 -- value. So first we release the session data then we set current
1313 -- session data to point to default session data.
1315 Free (Cur_Session.Data);
1316 Cur_Session.Data := Def_Session.Data;
1317 end GNAT.AWK;