OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [g-awk.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2010, AdaCore                     --
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,  51  Franklin  Street,  Fifth  Floor, --
20
-- Boston, MA 02110-1301, 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
------------------------------------------------------------------------------
33
 
34
pragma Ada_95;
35
--  This is needed because the pragmas Warnings (Off) in Current_Session and
36
--  Default_Session (see below) do not work when compiling clients of this
37
--  package that instantiate generic units herein.
38
 
39
with Ada.Exceptions;
40
with Ada.Text_IO;
41
with Ada.Strings.Unbounded;
42
with Ada.Strings.Fixed;
43
with Ada.Strings.Maps;
44
with Ada.Unchecked_Deallocation;
45
 
46
with GNAT.Directory_Operations;
47
with GNAT.Dynamic_Tables;
48
with GNAT.OS_Lib;
49
 
50
package body GNAT.AWK is
51
 
52
   use Ada;
53
   use Ada.Strings.Unbounded;
54
 
55
   -----------------------
56
   -- Local subprograms --
57
   -----------------------
58
 
59
   --  The following two subprograms provide a functional interface to the
60
   --  two special session variables, that are manipulated explicitly by
61
   --  Finalize, but must be declared after Finalize to prevent static
62
   --  elaboration warnings.
63
 
64
   function Get_Def return Session_Data_Access;
65
   procedure Set_Cur;
66
 
67
   ----------------
68
   -- Split mode --
69
   ----------------
70
 
71
   package Split is
72
 
73
      type Mode is abstract tagged null record;
74
      --  This is the main type which is declared abstract. This type must be
75
      --  derived for each split style.
76
 
77
      type Mode_Access is access Mode'Class;
78
 
79
      procedure Current_Line (S : Mode; Session : Session_Type)
80
        is abstract;
81
      --  Split current line of Session using split mode S
82
 
83
      ------------------------
84
      -- Split on separator --
85
      ------------------------
86
 
87
      type Separator (Size : Positive) is new Mode with record
88
         Separators : String (1 .. Size);
89
      end record;
90
 
91
      procedure Current_Line
92
        (S       : Separator;
93
         Session : Session_Type);
94
 
95
      ---------------------
96
      -- Split on column --
97
      ---------------------
98
 
99
      type Column (Size : Positive) is new Mode with record
100
         Columns : Widths_Set (1 .. Size);
101
      end record;
102
 
103
      procedure Current_Line (S : Column; Session : Session_Type);
104
 
105
   end Split;
106
 
107
   procedure Free is new Unchecked_Deallocation
108
     (Split.Mode'Class, Split.Mode_Access);
109
 
110
   ----------------
111
   -- File_Table --
112
   ----------------
113
 
114
   type AWK_File is access String;
115
 
116
   package File_Table is
117
      new Dynamic_Tables (AWK_File, Natural, 1, 5, 50);
118
   --  List of file names associated with a Session
119
 
120
   procedure Free is new Unchecked_Deallocation (String, AWK_File);
121
 
122
   -----------------
123
   -- Field_Table --
124
   -----------------
125
 
126
   type Field_Slice is record
127
      First : Positive;
128
      Last  : Natural;
129
   end record;
130
   --  This is a field slice (First .. Last) in session's current line
131
 
132
   package Field_Table is
133
      new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100);
134
   --  List of fields for the current line
135
 
136
   --------------
137
   -- Patterns --
138
   --------------
139
 
140
   --  Define all patterns style: exact string, regular expression, boolean
141
   --  function.
142
 
143
   package Patterns is
144
 
145
      type Pattern is abstract tagged null record;
146
      --  This is the main type which is declared abstract. This type must be
147
      --  derived for each patterns style.
148
 
149
      type Pattern_Access is access Pattern'Class;
150
 
151
      function Match
152
        (P       : Pattern;
153
         Session : Session_Type) return Boolean
154
      is abstract;
155
      --  Returns True if P match for the current session and False otherwise
156
 
157
      procedure Release (P : in out Pattern);
158
      --  Release memory used by the pattern structure
159
 
160
      --------------------------
161
      -- Exact string pattern --
162
      --------------------------
163
 
164
      type String_Pattern is new Pattern with record
165
         Str  : Unbounded_String;
166
         Rank : Count;
167
      end record;
168
 
169
      function Match
170
        (P       : String_Pattern;
171
         Session : Session_Type) return Boolean;
172
 
173
      --------------------------------
174
      -- Regular expression pattern --
175
      --------------------------------
176
 
177
      type Pattern_Matcher_Access is access Regpat.Pattern_Matcher;
178
 
179
      type Regexp_Pattern is new Pattern with record
180
         Regx : Pattern_Matcher_Access;
181
         Rank : Count;
182
      end record;
183
 
184
      function Match
185
        (P       : Regexp_Pattern;
186
         Session : Session_Type) return Boolean;
187
 
188
      procedure Release (P : in out Regexp_Pattern);
189
 
190
      ------------------------------
191
      -- Boolean function pattern --
192
      ------------------------------
193
 
194
      type Callback_Pattern is new Pattern with record
195
         Pattern : Pattern_Callback;
196
      end record;
197
 
198
      function Match
199
        (P       : Callback_Pattern;
200
         Session : Session_Type) return Boolean;
201
 
202
   end Patterns;
203
 
204
   procedure Free is new Unchecked_Deallocation
205
     (Patterns.Pattern'Class, Patterns.Pattern_Access);
206
 
207
   -------------
208
   -- Actions --
209
   -------------
210
 
211
   --  Define all action style : simple call, call with matches
212
 
213
   package Actions is
214
 
215
      type Action is abstract tagged null record;
216
      --  This is the main type which is declared abstract. This type must be
217
      --  derived for each action style.
218
 
219
      type Action_Access is access Action'Class;
220
 
221
      procedure Call
222
        (A       : Action;
223
         Session : Session_Type) is abstract;
224
      --  Call action A as required
225
 
226
      -------------------
227
      -- Simple action --
228
      -------------------
229
 
230
      type Simple_Action is new Action with record
231
         Proc : Action_Callback;
232
      end record;
233
 
234
      procedure Call
235
        (A       : Simple_Action;
236
         Session : Session_Type);
237
 
238
      -------------------------
239
      -- Action with matches --
240
      -------------------------
241
 
242
      type Match_Action is new Action with record
243
         Proc : Match_Action_Callback;
244
      end record;
245
 
246
      procedure Call
247
        (A       : Match_Action;
248
         Session : Session_Type);
249
 
250
   end Actions;
251
 
252
   procedure Free is new Unchecked_Deallocation
253
     (Actions.Action'Class, Actions.Action_Access);
254
 
255
   --------------------------
256
   -- Pattern/Action table --
257
   --------------------------
258
 
259
   type Pattern_Action is record
260
      Pattern : Patterns.Pattern_Access;  -- If Pattern is True
261
      Action  : Actions.Action_Access;    -- Action will be called
262
   end record;
263
 
264
   package Pattern_Action_Table is
265
      new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50);
266
 
267
   ------------------
268
   -- Session Data --
269
   ------------------
270
 
271
   type Session_Data is record
272
      Current_File : Text_IO.File_Type;
273
      Current_Line : Unbounded_String;
274
      Separators   : Split.Mode_Access;
275
      Files        : File_Table.Instance;
276
      File_Index   : Natural := 0;
277
      Fields       : Field_Table.Instance;
278
      Filters      : Pattern_Action_Table.Instance;
279
      NR           : Natural := 0;
280
      FNR          : Natural := 0;
281
      Matches      : Regpat.Match_Array (0 .. 100);
282
      --  Latest matches for the regexp pattern
283
   end record;
284
 
285
   procedure Free is
286
      new Unchecked_Deallocation (Session_Data, Session_Data_Access);
287
 
288
   --------------
289
   -- Finalize --
290
   --------------
291
 
292
   procedure Finalize (Session : in out Session_Type) is
293
   begin
294
      --  We release the session data only if it is not the default session
295
 
296
      if Session.Data /= Get_Def then
297
         --  Release separators
298
 
299
         Free (Session.Data.Separators);
300
 
301
         Free (Session.Data);
302
 
303
         --  Since we have closed the current session, set it to point now to
304
         --  the default session.
305
 
306
         Set_Cur;
307
      end if;
308
   end Finalize;
309
 
310
   ----------------
311
   -- Initialize --
312
   ----------------
313
 
314
   procedure Initialize (Session : in out Session_Type) is
315
   begin
316
      Session.Data := new Session_Data;
317
 
318
      --  Initialize separators
319
 
320
      Session.Data.Separators :=
321
        new Split.Separator'(Default_Separators'Length, Default_Separators);
322
 
323
      --  Initialize all tables
324
 
325
      File_Table.Init  (Session.Data.Files);
326
      Field_Table.Init (Session.Data.Fields);
327
      Pattern_Action_Table.Init (Session.Data.Filters);
328
   end Initialize;
329
 
330
   -----------------------
331
   -- Session Variables --
332
   -----------------------
333
 
334
   Def_Session : Session_Type;
335
   Cur_Session : Session_Type;
336
 
337
   ----------------------
338
   -- Private Services --
339
   ----------------------
340
 
341
   function Always_True return Boolean;
342
   --  A function that always returns True
343
 
344
   function Apply_Filters
345
     (Session : Session_Type) return Boolean;
346
   --  Apply any filters for which the Pattern is True for Session. It returns
347
   --  True if a least one filters has been applied (i.e. associated action
348
   --  callback has been called).
349
 
350
   procedure Open_Next_File
351
     (Session : Session_Type);
352
   pragma Inline (Open_Next_File);
353
   --  Open next file for Session closing current file if needed. It raises
354
   --  End_Error if there is no more file in the table.
355
 
356
   procedure Raise_With_Info
357
     (E       : Exceptions.Exception_Id;
358
      Message : String;
359
      Session : Session_Type);
360
   pragma No_Return (Raise_With_Info);
361
   --  Raises exception E with the message prepended with the current line
362
   --  number and the filename if possible.
363
 
364
   procedure Read_Line (Session : Session_Type);
365
   --  Read a line for the Session and set Current_Line
366
 
367
   procedure Split_Line (Session : Session_Type);
368
   --  Split session's Current_Line according to the session separators and
369
   --  set the Fields table. This procedure can be called at any time.
370
 
371
   ----------------------
372
   -- Private Packages --
373
   ----------------------
374
 
375
   -------------
376
   -- Actions --
377
   -------------
378
 
379
   package body Actions is
380
 
381
      ----------
382
      -- Call --
383
      ----------
384
 
385
      procedure Call
386
        (A       : Simple_Action;
387
         Session : Session_Type)
388
      is
389
         pragma Unreferenced (Session);
390
      begin
391
         A.Proc.all;
392
      end Call;
393
 
394
      ----------
395
      -- Call --
396
      ----------
397
 
398
      procedure Call
399
        (A       : Match_Action;
400
         Session : Session_Type)
401
      is
402
      begin
403
         A.Proc (Session.Data.Matches);
404
      end Call;
405
 
406
   end Actions;
407
 
408
   --------------
409
   -- Patterns --
410
   --------------
411
 
412
   package body Patterns is
413
 
414
      -----------
415
      -- Match --
416
      -----------
417
 
418
      function Match
419
        (P       : String_Pattern;
420
         Session : Session_Type) return Boolean
421
      is
422
      begin
423
         return P.Str = Field (P.Rank, Session);
424
      end Match;
425
 
426
      -----------
427
      -- Match --
428
      -----------
429
 
430
      function Match
431
        (P       : Regexp_Pattern;
432
         Session : Session_Type) return Boolean
433
      is
434
         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;
440
 
441
      -----------
442
      -- Match --
443
      -----------
444
 
445
      function Match
446
        (P       : Callback_Pattern;
447
         Session : Session_Type) return Boolean
448
      is
449
         pragma Unreferenced (Session);
450
      begin
451
         return P.Pattern.all;
452
      end Match;
453
 
454
      -------------
455
      -- Release --
456
      -------------
457
 
458
      procedure Release (P : in out Pattern) is
459
         pragma Unreferenced (P);
460
      begin
461
         null;
462
      end Release;
463
 
464
      -------------
465
      -- Release --
466
      -------------
467
 
468
      procedure Release (P : in out Regexp_Pattern) is
469
         procedure Free is new Unchecked_Deallocation
470
           (Regpat.Pattern_Matcher, Pattern_Matcher_Access);
471
      begin
472
         Free (P.Regx);
473
      end Release;
474
 
475
   end Patterns;
476
 
477
   -----------
478
   -- Split --
479
   -----------
480
 
481
   package body Split is
482
 
483
      use Ada.Strings;
484
 
485
      ------------------
486
      -- Current_Line --
487
      ------------------
488
 
489
      procedure Current_Line (S : Separator; Session : Session_Type) is
490
         Line   : constant String := To_String (Session.Data.Current_Line);
491
         Fields : Field_Table.Instance renames Session.Data.Fields;
492
         Seps   : constant Maps.Character_Set := Maps.To_Set (S.Separators);
493
 
494
         Start  : Natural;
495
         Stop   : Natural;
496
 
497
      begin
498
         --  First field start here
499
 
500
         Start := Line'First;
501
 
502
         --  Record the first field start position which is the first character
503
         --  in the line.
504
 
505
         Field_Table.Increment_Last (Fields);
506
         Fields.Table (Field_Table.Last (Fields)).First := Start;
507
 
508
         loop
509
            --  Look for next separator
510
 
511
            Stop := Fixed.Index
512
              (Source => Line (Start .. Line'Last),
513
               Set    => Seps);
514
 
515
            exit when Stop = 0;
516
 
517
            Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1;
518
 
519
            --  If separators are set to the default (space and tab) we skip
520
            --  all spaces and tabs following current field.
521
 
522
            if S.Separators = Default_Separators then
523
               Start := Fixed.Index
524
                 (Line (Stop + 1 .. Line'Last),
525
                  Maps.To_Set (Default_Separators),
526
                  Outside,
527
                  Strings.Forward);
528
 
529
               if Start = 0 then
530
                  Start := Stop + 1;
531
               end if;
532
 
533
            else
534
               Start := Stop + 1;
535
            end if;
536
 
537
            --  Record in the field table the start of this new field
538
 
539
            Field_Table.Increment_Last (Fields);
540
            Fields.Table (Field_Table.Last (Fields)).First := Start;
541
 
542
         end loop;
543
 
544
         Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
545
      end Current_Line;
546
 
547
      ------------------
548
      -- Current_Line --
549
      ------------------
550
 
551
      procedure Current_Line (S : Column; Session : Session_Type) is
552
         Line   : constant String := To_String (Session.Data.Current_Line);
553
         Fields : Field_Table.Instance renames Session.Data.Fields;
554
         Start  : Positive := Line'First;
555
 
556
      begin
557
         --  Record the first field start position which is the first character
558
         --  in the line.
559
 
560
         for C in 1 .. S.Columns'Length loop
561
 
562
            Field_Table.Increment_Last (Fields);
563
 
564
            Fields.Table (Field_Table.Last (Fields)).First := Start;
565
 
566
            Start := Start + S.Columns (C);
567
 
568
            Fields.Table (Field_Table.Last (Fields)).Last := Start - 1;
569
 
570
         end loop;
571
 
572
         --  If there is some remaining character on the line, add them in a
573
         --  new field.
574
 
575
         if Start - 1 < Line'Length then
576
 
577
            Field_Table.Increment_Last (Fields);
578
 
579
            Fields.Table (Field_Table.Last (Fields)).First := Start;
580
 
581
            Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
582
         end if;
583
      end Current_Line;
584
 
585
   end Split;
586
 
587
   --------------
588
   -- Add_File --
589
   --------------
590
 
591
   procedure Add_File
592
     (Filename : String;
593
      Session  : Session_Type)
594
   is
595
      Files : File_Table.Instance renames Session.Data.Files;
596
 
597
   begin
598
      if OS_Lib.Is_Regular_File (Filename) then
599
         File_Table.Increment_Last (Files);
600
         Files.Table (File_Table.Last (Files)) := new String'(Filename);
601
      else
602
         Raise_With_Info
603
           (File_Error'Identity,
604
            "File " & Filename & " not found.",
605
            Session);
606
      end if;
607
   end Add_File;
608
 
609
   procedure Add_File
610
     (Filename : String)
611
   is
612
 
613
   begin
614
      Add_File (Filename, Cur_Session);
615
   end Add_File;
616
 
617
   ---------------
618
   -- Add_Files --
619
   ---------------
620
 
621
   procedure Add_Files
622
     (Directory             : String;
623
      Filenames             : String;
624
      Number_Of_Files_Added : out Natural;
625
      Session               : Session_Type)
626
   is
627
      use Directory_Operations;
628
 
629
      Dir      : Dir_Type;
630
      Filename : String (1 .. 200);
631
      Last     : Natural;
632
 
633
   begin
634
      Number_Of_Files_Added := 0;
635
 
636
      Open (Dir, Directory);
637
 
638
      loop
639
         Read (Dir, Filename, Last);
640
         exit when Last = 0;
641
 
642
         Add_File (Filename (1 .. Last), Session);
643
         Number_Of_Files_Added := Number_Of_Files_Added + 1;
644
      end loop;
645
 
646
      Close (Dir);
647
 
648
   exception
649
      when others =>
650
         Raise_With_Info
651
           (File_Error'Identity,
652
            "Error scanning directory " & Directory
653
            & " for files " & Filenames & '.',
654
            Session);
655
   end Add_Files;
656
 
657
   procedure Add_Files
658
     (Directory             : String;
659
      Filenames             : String;
660
      Number_Of_Files_Added : out Natural)
661
   is
662
 
663
   begin
664
      Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session);
665
   end Add_Files;
666
 
667
   -----------------
668
   -- Always_True --
669
   -----------------
670
 
671
   function Always_True return Boolean is
672
   begin
673
      return True;
674
   end Always_True;
675
 
676
   -------------------
677
   -- Apply_Filters --
678
   -------------------
679
 
680
   function Apply_Filters
681
     (Session : Session_Type) return Boolean
682
   is
683
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
684
      Results : Boolean := False;
685
 
686
   begin
687
      --  Iterate through the filters table, if pattern match call action
688
 
689
      for F in 1 .. Pattern_Action_Table.Last (Filters) loop
690
         if Patterns.Match (Filters.Table (F).Pattern.all, Session) then
691
            Results := True;
692
            Actions.Call (Filters.Table (F).Action.all, Session);
693
         end if;
694
      end loop;
695
 
696
      return Results;
697
   end Apply_Filters;
698
 
699
   -----------
700
   -- Close --
701
   -----------
702
 
703
   procedure Close (Session : Session_Type) is
704
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
705
      Files   : File_Table.Instance renames Session.Data.Files;
706
 
707
   begin
708
      --  Close current file if needed
709
 
710
      if Text_IO.Is_Open (Session.Data.Current_File) then
711
         Text_IO.Close (Session.Data.Current_File);
712
      end if;
713
 
714
      --  Release Filters table
715
 
716
      for F in 1 .. Pattern_Action_Table.Last (Filters) loop
717
         Patterns.Release (Filters.Table (F).Pattern.all);
718
         Free (Filters.Table (F).Pattern);
719
         Free (Filters.Table (F).Action);
720
      end loop;
721
 
722
      for F in 1 .. File_Table.Last (Files) loop
723
         Free (Files.Table (F));
724
      end loop;
725
 
726
      File_Table.Set_Last (Session.Data.Files, 0);
727
      Field_Table.Set_Last (Session.Data.Fields, 0);
728
      Pattern_Action_Table.Set_Last (Session.Data.Filters, 0);
729
 
730
      Session.Data.NR := 0;
731
      Session.Data.FNR := 0;
732
      Session.Data.File_Index := 0;
733
      Session.Data.Current_Line := Null_Unbounded_String;
734
   end Close;
735
 
736
   ---------------------
737
   -- Current_Session --
738
   ---------------------
739
 
740
   function Current_Session return Session_Type is
741
   begin
742
      pragma Warnings (Off);
743
      return Cur_Session;
744
      --  ???The above return statement violates the Ada 2005 rule forbidding
745
      --  copying of limited objects (see RM-7.5(2.8/2)). When compiled with
746
      --  -gnatg, the compiler gives a warning instead of an error, so we can
747
      --  turn it off.
748
      pragma Warnings (On);
749
   end Current_Session;
750
 
751
   ---------------------
752
   -- Default_Session --
753
   ---------------------
754
 
755
   function Default_Session return Session_Type is
756
   begin
757
      pragma Warnings (Off);
758
      return Def_Session;
759
      --  ???The above return statement violates the Ada 2005 rule forbidding
760
      --  copying of limited objects (see RM-7.5(2.8/2)). When compiled with
761
      --  -gnatg, the compiler gives a warning instead of an error, so we can
762
      --  turn it off.
763
      pragma Warnings (On);
764
   end Default_Session;
765
 
766
   --------------------
767
   -- Discrete_Field --
768
   --------------------
769
 
770
   function Discrete_Field
771
     (Rank    : Count;
772
      Session : Session_Type) return Discrete
773
   is
774
   begin
775
      return Discrete'Value (Field (Rank, Session));
776
   end Discrete_Field;
777
 
778
   function Discrete_Field_Current_Session
779
     (Rank    : Count) return Discrete is
780
      function Do_It is new Discrete_Field (Discrete);
781
   begin
782
      return Do_It (Rank, Cur_Session);
783
   end Discrete_Field_Current_Session;
784
 
785
   -----------------
786
   -- End_Of_Data --
787
   -----------------
788
 
789
   function End_Of_Data
790
     (Session : Session_Type) return Boolean
791
   is
792
   begin
793
      return Session.Data.File_Index = File_Table.Last (Session.Data.Files)
794
        and then End_Of_File (Session);
795
   end End_Of_Data;
796
 
797
   function End_Of_Data
798
     return Boolean
799
   is
800
   begin
801
      return End_Of_Data (Cur_Session);
802
   end End_Of_Data;
803
 
804
   -----------------
805
   -- End_Of_File --
806
   -----------------
807
 
808
   function End_Of_File
809
     (Session : Session_Type) return Boolean
810
   is
811
   begin
812
      return Text_IO.End_Of_File (Session.Data.Current_File);
813
   end End_Of_File;
814
 
815
   function End_Of_File
816
     return Boolean
817
   is
818
   begin
819
      return End_Of_File (Cur_Session);
820
   end End_Of_File;
821
 
822
   -----------
823
   -- Field --
824
   -----------
825
 
826
   function Field
827
     (Rank    : Count;
828
      Session : Session_Type) return String
829
   is
830
      Fields : Field_Table.Instance renames Session.Data.Fields;
831
 
832
   begin
833
      if Rank > Number_Of_Fields (Session) then
834
         Raise_With_Info
835
           (Field_Error'Identity,
836
            "Field number" & Count'Image (Rank) & " does not exist.",
837
            Session);
838
 
839
      elsif Rank = 0 then
840
 
841
         --  Returns the whole line, this is what $0 does under Session_Type
842
 
843
         return To_String (Session.Data.Current_Line);
844
 
845
      else
846
         return Slice (Session.Data.Current_Line,
847
                       Fields.Table (Positive (Rank)).First,
848
                       Fields.Table (Positive (Rank)).Last);
849
      end if;
850
   end Field;
851
 
852
   function Field
853
     (Rank    : Count) return String
854
   is
855
   begin
856
      return Field (Rank, Cur_Session);
857
   end Field;
858
 
859
   function Field
860
     (Rank    : Count;
861
      Session : Session_Type) return Integer
862
   is
863
   begin
864
      return Integer'Value (Field (Rank, Session));
865
 
866
   exception
867
      when Constraint_Error =>
868
         Raise_With_Info
869
           (Field_Error'Identity,
870
            "Field number" & Count'Image (Rank)
871
            & " cannot be converted to an integer.",
872
            Session);
873
   end Field;
874
 
875
   function Field
876
     (Rank    : Count) return Integer
877
   is
878
   begin
879
      return Field (Rank, Cur_Session);
880
   end Field;
881
 
882
   function Field
883
     (Rank    : Count;
884
      Session : Session_Type) return Float
885
   is
886
   begin
887
      return Float'Value (Field (Rank, Session));
888
 
889
   exception
890
      when Constraint_Error =>
891
         Raise_With_Info
892
           (Field_Error'Identity,
893
            "Field number" & Count'Image (Rank)
894
            & " cannot be converted to a float.",
895
            Session);
896
   end Field;
897
 
898
   function Field
899
     (Rank    : Count) return Float
900
   is
901
   begin
902
      return Field (Rank, Cur_Session);
903
   end Field;
904
 
905
   ----------
906
   -- File --
907
   ----------
908
 
909
   function File
910
     (Session : Session_Type) return String
911
   is
912
      Files : File_Table.Instance renames Session.Data.Files;
913
 
914
   begin
915
      if Session.Data.File_Index = 0 then
916
         return "??";
917
      else
918
         return Files.Table (Session.Data.File_Index).all;
919
      end if;
920
   end File;
921
 
922
   function File
923
     return String
924
   is
925
   begin
926
      return File (Cur_Session);
927
   end File;
928
 
929
   --------------------
930
   -- For_Every_Line --
931
   --------------------
932
 
933
   procedure For_Every_Line
934
     (Separators : String        := Use_Current;
935
      Filename   : String        := Use_Current;
936
      Callbacks  : Callback_Mode := None;
937
      Session    : Session_Type)
938
   is
939
      Quit : Boolean;
940
 
941
   begin
942
      Open (Separators, Filename, Session);
943
 
944
      while not End_Of_Data (Session) loop
945
         Read_Line (Session);
946
         Split_Line (Session);
947
 
948
         if Callbacks in Only .. Pass_Through then
949
            declare
950
               Discard : Boolean;
951
               pragma Unreferenced (Discard);
952
            begin
953
               Discard := Apply_Filters (Session);
954
            end;
955
         end if;
956
 
957
         if Callbacks /= Only then
958
            Quit := False;
959
            Action (Quit);
960
            exit when Quit;
961
         end if;
962
      end loop;
963
 
964
      Close (Session);
965
   end For_Every_Line;
966
 
967
   procedure For_Every_Line_Current_Session
968
     (Separators : String        := Use_Current;
969
      Filename   : String        := Use_Current;
970
      Callbacks  : Callback_Mode := None)
971
   is
972
      procedure Do_It is new For_Every_Line (Action);
973
   begin
974
      Do_It (Separators, Filename, Callbacks, Cur_Session);
975
   end For_Every_Line_Current_Session;
976
 
977
   --------------
978
   -- Get_Line --
979
   --------------
980
 
981
   procedure Get_Line
982
     (Callbacks : Callback_Mode := None;
983
      Session   : Session_Type)
984
   is
985
      Filter_Active : Boolean;
986
 
987
   begin
988
      if not Text_IO.Is_Open (Session.Data.Current_File) then
989
         raise File_Error;
990
      end if;
991
 
992
      loop
993
         Read_Line (Session);
994
         Split_Line (Session);
995
 
996
         case Callbacks is
997
 
998
            when None =>
999
               exit;
1000
 
1001
            when Only =>
1002
               Filter_Active := Apply_Filters (Session);
1003
               exit when not Filter_Active;
1004
 
1005
            when Pass_Through =>
1006
               Filter_Active := Apply_Filters (Session);
1007
               exit;
1008
 
1009
         end case;
1010
      end loop;
1011
   end Get_Line;
1012
 
1013
   procedure Get_Line
1014
     (Callbacks : Callback_Mode := None)
1015
   is
1016
   begin
1017
      Get_Line (Callbacks, Cur_Session);
1018
   end Get_Line;
1019
 
1020
   ----------------------
1021
   -- Number_Of_Fields --
1022
   ----------------------
1023
 
1024
   function Number_Of_Fields
1025
     (Session : Session_Type) return Count
1026
   is
1027
   begin
1028
      return Count (Field_Table.Last (Session.Data.Fields));
1029
   end Number_Of_Fields;
1030
 
1031
   function Number_Of_Fields
1032
     return Count
1033
   is
1034
   begin
1035
      return Number_Of_Fields (Cur_Session);
1036
   end Number_Of_Fields;
1037
 
1038
   --------------------------
1039
   -- Number_Of_File_Lines --
1040
   --------------------------
1041
 
1042
   function Number_Of_File_Lines
1043
     (Session : Session_Type) return Count
1044
   is
1045
   begin
1046
      return Count (Session.Data.FNR);
1047
   end Number_Of_File_Lines;
1048
 
1049
   function Number_Of_File_Lines
1050
     return Count
1051
   is
1052
   begin
1053
      return Number_Of_File_Lines (Cur_Session);
1054
   end Number_Of_File_Lines;
1055
 
1056
   ---------------------
1057
   -- Number_Of_Files --
1058
   ---------------------
1059
 
1060
   function Number_Of_Files
1061
     (Session : Session_Type) return Natural
1062
   is
1063
      Files : File_Table.Instance renames Session.Data.Files;
1064
   begin
1065
      return File_Table.Last (Files);
1066
   end Number_Of_Files;
1067
 
1068
   function Number_Of_Files
1069
     return Natural
1070
   is
1071
   begin
1072
      return Number_Of_Files (Cur_Session);
1073
   end Number_Of_Files;
1074
 
1075
   ---------------------
1076
   -- Number_Of_Lines --
1077
   ---------------------
1078
 
1079
   function Number_Of_Lines
1080
     (Session : Session_Type) return Count
1081
   is
1082
   begin
1083
      return Count (Session.Data.NR);
1084
   end Number_Of_Lines;
1085
 
1086
   function Number_Of_Lines
1087
     return Count
1088
   is
1089
   begin
1090
      return Number_Of_Lines (Cur_Session);
1091
   end Number_Of_Lines;
1092
 
1093
   ----------
1094
   -- Open --
1095
   ----------
1096
 
1097
   procedure Open
1098
     (Separators : String       := Use_Current;
1099
      Filename   : String       := Use_Current;
1100
      Session    : Session_Type)
1101
   is
1102
   begin
1103
      if Text_IO.Is_Open (Session.Data.Current_File) then
1104
         raise Session_Error;
1105
      end if;
1106
 
1107
      if Filename /= Use_Current then
1108
         File_Table.Init (Session.Data.Files);
1109
         Add_File (Filename, Session);
1110
      end if;
1111
 
1112
      if Separators /= Use_Current then
1113
         Set_Field_Separators (Separators, Session);
1114
      end if;
1115
 
1116
      Open_Next_File (Session);
1117
 
1118
   exception
1119
      when End_Error =>
1120
         raise File_Error;
1121
   end Open;
1122
 
1123
   procedure Open
1124
     (Separators : String       := Use_Current;
1125
      Filename   : String       := Use_Current)
1126
   is
1127
   begin
1128
      Open (Separators, Filename, Cur_Session);
1129
   end Open;
1130
 
1131
   --------------------
1132
   -- Open_Next_File --
1133
   --------------------
1134
 
1135
   procedure Open_Next_File
1136
     (Session : Session_Type)
1137
   is
1138
      Files : File_Table.Instance renames Session.Data.Files;
1139
 
1140
   begin
1141
      if Text_IO.Is_Open (Session.Data.Current_File) then
1142
         Text_IO.Close (Session.Data.Current_File);
1143
      end if;
1144
 
1145
      Session.Data.File_Index := Session.Data.File_Index + 1;
1146
 
1147
      --  If there are no mores file in the table, raise End_Error
1148
 
1149
      if Session.Data.File_Index > File_Table.Last (Files) then
1150
         raise End_Error;
1151
      end if;
1152
 
1153
      Text_IO.Open
1154
        (File => Session.Data.Current_File,
1155
         Name => Files.Table (Session.Data.File_Index).all,
1156
         Mode => Text_IO.In_File);
1157
   end Open_Next_File;
1158
 
1159
   -----------
1160
   -- Parse --
1161
   -----------
1162
 
1163
   procedure Parse
1164
     (Separators : String       := Use_Current;
1165
      Filename   : String       := Use_Current;
1166
      Session    : Session_Type)
1167
   is
1168
      Filter_Active : Boolean;
1169
      pragma Unreferenced (Filter_Active);
1170
 
1171
   begin
1172
      Open (Separators, Filename, Session);
1173
 
1174
      while not End_Of_Data (Session) loop
1175
         Get_Line (None, Session);
1176
         Filter_Active := Apply_Filters (Session);
1177
      end loop;
1178
 
1179
      Close (Session);
1180
   end Parse;
1181
 
1182
   procedure Parse
1183
     (Separators : String       := Use_Current;
1184
      Filename   : String       := Use_Current)
1185
   is
1186
   begin
1187
      Parse (Separators, Filename, Cur_Session);
1188
   end Parse;
1189
 
1190
   ---------------------
1191
   -- Raise_With_Info --
1192
   ---------------------
1193
 
1194
   procedure Raise_With_Info
1195
     (E       : Exceptions.Exception_Id;
1196
      Message : String;
1197
      Session : Session_Type)
1198
   is
1199
      function Filename return String;
1200
      --  Returns current filename and "??" if this information is not
1201
      --  available.
1202
 
1203
      function Line return String;
1204
      --  Returns current line number without the leading space
1205
 
1206
      --------------
1207
      -- Filename --
1208
      --------------
1209
 
1210
      function Filename return String is
1211
         File : constant String := AWK.File (Session);
1212
      begin
1213
         if File = "" then
1214
            return "??";
1215
         else
1216
            return File;
1217
         end if;
1218
      end Filename;
1219
 
1220
      ----------
1221
      -- Line --
1222
      ----------
1223
 
1224
      function Line return String is
1225
         L : constant String := Natural'Image (Session.Data.FNR);
1226
      begin
1227
         return L (2 .. L'Last);
1228
      end Line;
1229
 
1230
   --  Start of processing for Raise_With_Info
1231
 
1232
   begin
1233
      Exceptions.Raise_Exception
1234
        (E,
1235
         '[' & Filename & ':' & Line & "] " & Message);
1236
      raise Constraint_Error; -- to please GNAT as this is a No_Return proc
1237
   end Raise_With_Info;
1238
 
1239
   ---------------
1240
   -- Read_Line --
1241
   ---------------
1242
 
1243
   procedure Read_Line (Session : Session_Type) is
1244
 
1245
      function Read_Line return String;
1246
      --  Read a line in the current file. This implementation is recursive
1247
      --  and does not have a limitation on the line length.
1248
 
1249
      NR  : Natural renames Session.Data.NR;
1250
      FNR : Natural renames Session.Data.FNR;
1251
 
1252
      ---------------
1253
      -- Read_Line --
1254
      ---------------
1255
 
1256
      function Read_Line return String is
1257
         Buffer : String (1 .. 1_024);
1258
         Last   : Natural;
1259
 
1260
      begin
1261
         Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last);
1262
 
1263
         if Last = Buffer'Last then
1264
            return Buffer & Read_Line;
1265
         else
1266
            return Buffer (1 .. Last);
1267
         end if;
1268
      end Read_Line;
1269
 
1270
   --  Start of processing for Read_Line
1271
 
1272
   begin
1273
      if End_Of_File (Session) then
1274
         Open_Next_File (Session);
1275
         FNR := 0;
1276
      end if;
1277
 
1278
      Session.Data.Current_Line := To_Unbounded_String (Read_Line);
1279
 
1280
      NR := NR + 1;
1281
      FNR := FNR + 1;
1282
   end Read_Line;
1283
 
1284
   --------------
1285
   -- Register --
1286
   --------------
1287
 
1288
   procedure Register
1289
     (Field   : Count;
1290
      Pattern : String;
1291
      Action  : Action_Callback;
1292
      Session : Session_Type)
1293
   is
1294
      Filters   : Pattern_Action_Table.Instance renames Session.Data.Filters;
1295
      U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern);
1296
 
1297
   begin
1298
      Pattern_Action_Table.Increment_Last (Filters);
1299
 
1300
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1301
        (Pattern => new Patterns.String_Pattern'(U_Pattern, Field),
1302
         Action  => new Actions.Simple_Action'(Proc => Action));
1303
   end Register;
1304
 
1305
   procedure Register
1306
     (Field   : Count;
1307
      Pattern : String;
1308
      Action  : Action_Callback)
1309
   is
1310
   begin
1311
      Register (Field, Pattern, Action, Cur_Session);
1312
   end Register;
1313
 
1314
   procedure Register
1315
     (Field   : Count;
1316
      Pattern : GNAT.Regpat.Pattern_Matcher;
1317
      Action  : Action_Callback;
1318
      Session : Session_Type)
1319
   is
1320
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1321
 
1322
      A_Pattern : constant Patterns.Pattern_Matcher_Access :=
1323
                    new Regpat.Pattern_Matcher'(Pattern);
1324
   begin
1325
      Pattern_Action_Table.Increment_Last (Filters);
1326
 
1327
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1328
        (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
1329
         Action  => new Actions.Simple_Action'(Proc => Action));
1330
   end Register;
1331
 
1332
   procedure Register
1333
     (Field   : Count;
1334
      Pattern : GNAT.Regpat.Pattern_Matcher;
1335
      Action  : Action_Callback)
1336
   is
1337
   begin
1338
      Register (Field, Pattern, Action, Cur_Session);
1339
   end Register;
1340
 
1341
   procedure Register
1342
     (Field   : Count;
1343
      Pattern : GNAT.Regpat.Pattern_Matcher;
1344
      Action  : Match_Action_Callback;
1345
      Session : Session_Type)
1346
   is
1347
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1348
 
1349
      A_Pattern : constant Patterns.Pattern_Matcher_Access :=
1350
                    new Regpat.Pattern_Matcher'(Pattern);
1351
   begin
1352
      Pattern_Action_Table.Increment_Last (Filters);
1353
 
1354
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1355
        (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
1356
         Action  => new Actions.Match_Action'(Proc => Action));
1357
   end Register;
1358
 
1359
   procedure Register
1360
     (Field   : Count;
1361
      Pattern : GNAT.Regpat.Pattern_Matcher;
1362
      Action  : Match_Action_Callback)
1363
   is
1364
   begin
1365
      Register (Field, Pattern, Action, Cur_Session);
1366
   end Register;
1367
 
1368
   procedure Register
1369
     (Pattern : Pattern_Callback;
1370
      Action  : Action_Callback;
1371
      Session : Session_Type)
1372
   is
1373
      Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
1374
 
1375
   begin
1376
      Pattern_Action_Table.Increment_Last (Filters);
1377
 
1378
      Filters.Table (Pattern_Action_Table.Last (Filters)) :=
1379
        (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern),
1380
         Action  => new Actions.Simple_Action'(Proc => Action));
1381
   end Register;
1382
 
1383
   procedure Register
1384
     (Pattern : Pattern_Callback;
1385
      Action  : Action_Callback)
1386
   is
1387
   begin
1388
      Register (Pattern, Action, Cur_Session);
1389
   end Register;
1390
 
1391
   procedure Register
1392
     (Action  : Action_Callback;
1393
      Session : Session_Type)
1394
   is
1395
   begin
1396
      Register (Always_True'Access, Action, Session);
1397
   end Register;
1398
 
1399
   procedure Register
1400
     (Action  : Action_Callback)
1401
   is
1402
   begin
1403
      Register (Action, Cur_Session);
1404
   end Register;
1405
 
1406
   -----------------
1407
   -- Set_Current --
1408
   -----------------
1409
 
1410
   procedure Set_Current (Session : Session_Type) is
1411
   begin
1412
      Cur_Session.Data := Session.Data;
1413
   end Set_Current;
1414
 
1415
   --------------------------
1416
   -- Set_Field_Separators --
1417
   --------------------------
1418
 
1419
   procedure Set_Field_Separators
1420
     (Separators : String       := Default_Separators;
1421
      Session    : Session_Type)
1422
   is
1423
   begin
1424
      Free (Session.Data.Separators);
1425
 
1426
      Session.Data.Separators :=
1427
        new Split.Separator'(Separators'Length, Separators);
1428
 
1429
      --  If there is a current line read, split it according to the new
1430
      --  separators.
1431
 
1432
      if Session.Data.Current_Line /= Null_Unbounded_String then
1433
         Split_Line (Session);
1434
      end if;
1435
   end Set_Field_Separators;
1436
 
1437
   procedure Set_Field_Separators
1438
     (Separators : String       := Default_Separators)
1439
   is
1440
   begin
1441
      Set_Field_Separators (Separators, Cur_Session);
1442
   end Set_Field_Separators;
1443
 
1444
   ----------------------
1445
   -- Set_Field_Widths --
1446
   ----------------------
1447
 
1448
   procedure Set_Field_Widths
1449
     (Field_Widths : Widths_Set;
1450
      Session      : Session_Type)
1451
   is
1452
   begin
1453
      Free (Session.Data.Separators);
1454
 
1455
      Session.Data.Separators :=
1456
        new Split.Column'(Field_Widths'Length, Field_Widths);
1457
 
1458
      --  If there is a current line read, split it according to
1459
      --  the new separators.
1460
 
1461
      if Session.Data.Current_Line /= Null_Unbounded_String then
1462
         Split_Line (Session);
1463
      end if;
1464
   end Set_Field_Widths;
1465
 
1466
   procedure Set_Field_Widths
1467
     (Field_Widths : Widths_Set)
1468
   is
1469
   begin
1470
      Set_Field_Widths (Field_Widths, Cur_Session);
1471
   end Set_Field_Widths;
1472
 
1473
   ----------------
1474
   -- Split_Line --
1475
   ----------------
1476
 
1477
   procedure Split_Line (Session : Session_Type) is
1478
      Fields : Field_Table.Instance renames Session.Data.Fields;
1479
   begin
1480
      Field_Table.Init (Fields);
1481
      Split.Current_Line (Session.Data.Separators.all, Session);
1482
   end Split_Line;
1483
 
1484
   -------------
1485
   -- Get_Def --
1486
   -------------
1487
 
1488
   function Get_Def return Session_Data_Access is
1489
   begin
1490
      return Def_Session.Data;
1491
   end Get_Def;
1492
 
1493
   -------------
1494
   -- Set_Cur --
1495
   -------------
1496
 
1497
   procedure Set_Cur is
1498
   begin
1499
      Cur_Session.Data := Def_Session.Data;
1500
   end Set_Cur;
1501
 
1502
begin
1503
   --  We have declared two sessions but both should share the same data.
1504
   --  The current session must point to the default session as its initial
1505
   --  value. So first we release the session data then we set current
1506
   --  session data to point to default session data.
1507
 
1508
   Free (Cur_Session.Data);
1509
   Cur_Session.Data := Def_Session.Data;
1510
end GNAT.AWK;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.