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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-awk.adb] - Blame information for rev 827

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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