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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S F N _ S C A N                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2000-2010, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 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; use Ada.Exceptions;
33
 
34
package body SFN_Scan is
35
 
36
   use ASCII;
37
   --  Allow easy access to control character definitions
38
 
39
   EOF : constant Character := ASCII.SUB;
40
   --  The character SUB (16#1A#) is used in DOS-derived systems, such as
41
   --  Windows to signal the end of a text file. If this character appears as
42
   --  the last character of a file scanned by a call to Scan_SFN_Pragmas, then
43
   --  it is ignored, otherwise it is treated as an illegal character.
44
 
45
   type String_Ptr is access String;
46
 
47
   S : String_Ptr;
48
   --  Points to the gnat.adc input file
49
 
50
   P : Natural;
51
   --  Subscript of next character to process in S
52
 
53
   Line_Num : Natural;
54
   --  Current line number
55
 
56
   Start_Of_Line : Natural;
57
   --  Subscript of first character at start of current line
58
 
59
   ----------------------
60
   -- Local Procedures --
61
   ----------------------
62
 
63
   function Acquire_Integer return Natural;
64
   --  This function skips white space, and then scans and returns
65
   --  an unsigned integer. Raises Error if no integer is present
66
   --  or if the integer is greater than 999.
67
 
68
   function Acquire_String (B : Natural; E : Natural) return String;
69
   --  This function takes a string scanned out by Scan_String, strips
70
   --  the enclosing quote characters and any internal doubled quote
71
   --  characters, and returns the result as a String. The arguments
72
   --  B and E are as returned from a call to Scan_String. The lower
73
   --  bound of the string returned is always 1.
74
 
75
   function Acquire_Unit_Name return String;
76
   --  Skips white space, and then scans and returns a unit name. The
77
   --  unit name is cased exactly as it appears in the source file.
78
   --  The terminating character must be white space, or a comma or
79
   --  a right parenthesis or end of file.
80
 
81
   function At_EOF return Boolean;
82
   pragma Inline (At_EOF);
83
   --  Returns True if at end of file, False if not. Note that this
84
   --  function does NOT skip white space, so P is always unchanged.
85
 
86
   procedure Check_Not_At_EOF;
87
   pragma Inline (Check_Not_At_EOF);
88
   --  Skips past white space if any, and then raises Error if at
89
   --  end of file. Otherwise returns with P skipped past whitespace.
90
 
91
   function Check_File_Type return Character;
92
   --  Skips white space if any, and then looks for any of the tokens
93
   --  Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
94
   --  of these is found then the value returned is 's', 'b' or 'u'
95
   --  respectively, and P is bumped past the token. If none of
96
   --  these tokens is found, then P is unchanged (except for
97
   --  possible skip of white space), and a space is returned.
98
 
99
   function Check_Token (T : String) return Boolean;
100
   --  Skips white space if any, and then checks if the string at the
101
   --  current location matches the given string T, and the character
102
   --  immediately following is non-alphabetic, non-numeric. If so,
103
   --  P is stepped past the token, and True is returned. If not,
104
   --  P is unchanged (except for possibly skipping past whitespace),
105
   --  and False is returned. S may contain only lower-case letters
106
   --  ('a' .. 'z').
107
 
108
   procedure Error (Err : String);
109
   --  Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
110
   --  with a message of the form gnat.adc:line:col: xxx, where xxx is
111
   --  the string Err passed as a parameter.
112
 
113
   procedure Require_Token (T : String);
114
   --  Skips white space if any, and then requires the given string
115
   --  to be present. If it is, the P is stepped past it, otherwise
116
   --  Error is raised, since this is a syntax error. Require_Token
117
   --  is used only for sequences of special characters, so there
118
   --  is no issue of terminators, or casing of letters.
119
 
120
   procedure Scan_String (B : out Natural; E : out Natural);
121
   --  Skips white space if any, then requires that a double quote
122
   --  or percent be present (start of string). Raises error if
123
   --  neither of these two characters is found. Otherwise scans
124
   --  out the string, and returns with P pointing past the
125
   --  closing quote and S (B .. E) contains the characters of the
126
   --  string (including the enclosing quotes, with internal quotes
127
   --  still doubled). Raises Error if the string is malformed.
128
 
129
   procedure Skip_WS;
130
   --  Skips P past any white space characters (end of line
131
   --  characters, spaces, comments, horizontal tab characters).
132
 
133
   ---------------------
134
   -- Acquire_Integer --
135
   ---------------------
136
 
137
   function Acquire_Integer return Natural is
138
      N : Natural := 0;
139
 
140
   begin
141
      Skip_WS;
142
 
143
      if S (P) not in '0' .. '9' then
144
         Error ("missing index parameter");
145
      end if;
146
 
147
      while S (P) in '0' .. '9' loop
148
         N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
149
 
150
         if N > 999 then
151
            Error ("index value greater than 999");
152
         end if;
153
 
154
         P := P + 1;
155
      end loop;
156
 
157
      return N;
158
   end Acquire_Integer;
159
 
160
   --------------------
161
   -- Acquire_String --
162
   --------------------
163
 
164
   function Acquire_String (B : Natural; E : Natural) return String is
165
      Str : String (1 .. E - B - 1);
166
      Q   : constant Character := S (B);
167
      J   : Natural;
168
      Ptr : Natural;
169
 
170
   begin
171
      Ptr := B + 1;
172
      J := 0;
173
      while Ptr < E loop
174
         J := J + 1;
175
         Str (J) := S (Ptr);
176
 
177
         if S (Ptr) = Q and then S (Ptr + 1) = Q then
178
            Ptr := Ptr + 2;
179
         else
180
            Ptr := Ptr + 1;
181
         end if;
182
      end loop;
183
 
184
      return Str (1 .. J);
185
   end Acquire_String;
186
 
187
   -----------------------
188
   -- Acquire_Unit_Name --
189
   -----------------------
190
 
191
   function Acquire_Unit_Name return String is
192
      B : Natural;
193
 
194
   begin
195
      Check_Not_At_EOF;
196
      B := P;
197
 
198
      while not At_EOF loop
199
         exit when S (P) not in '0' .. '9'
200
           and then S (P) /= '.'
201
           and then S (P) /= '_'
202
           and then not (S (P) = '[' and then S (P + 1) = '"')
203
           and then not (S (P) = '"' and then S (P - 1) = '[')
204
           and then not (S (P) = '"' and then S (P + 1) = ']')
205
           and then not (S (P) = ']' and then S (P - 1) = '"')
206
           and then S (P) < 'A';
207
         P := P + 1;
208
      end loop;
209
 
210
      if P = B then
211
         Error ("null unit name");
212
      end if;
213
 
214
      return S (B .. P - 1);
215
   end Acquire_Unit_Name;
216
 
217
   ------------
218
   -- At_EOF --
219
   ------------
220
 
221
   function At_EOF return Boolean is
222
   begin
223
      --  Immediate return (False) if before last character of file
224
 
225
      if P < S'Last then
226
         return False;
227
 
228
      --  Special case: DOS EOF character as last character of file is
229
      --  allowed and treated as an end of file.
230
 
231
      elsif P = S'Last then
232
         return S (P) = EOF;
233
 
234
      --  If beyond last character of file, then definitely at EOF
235
 
236
      else
237
         return True;
238
      end if;
239
   end At_EOF;
240
 
241
   ---------------------
242
   -- Check_File_Type --
243
   ---------------------
244
 
245
   function Check_File_Type return Character is
246
   begin
247
      if Check_Token ("spec_file_name") then
248
         return 's';
249
      elsif Check_Token ("body_file_name") then
250
         return 'b';
251
      elsif Check_Token ("subunit_file_name") then
252
         return 'u';
253
      else
254
         return ' ';
255
      end if;
256
   end Check_File_Type;
257
 
258
   ----------------------
259
   -- Check_Not_At_EOF --
260
   ----------------------
261
 
262
   procedure Check_Not_At_EOF is
263
   begin
264
      Skip_WS;
265
 
266
      if At_EOF then
267
         Error ("unexpected end of file");
268
      end if;
269
 
270
      return;
271
   end Check_Not_At_EOF;
272
 
273
   -----------------
274
   -- Check_Token --
275
   -----------------
276
 
277
   function Check_Token (T : String) return Boolean is
278
      Save_P : Natural;
279
      C : Character;
280
 
281
   begin
282
      Skip_WS;
283
      Save_P := P;
284
 
285
      for K in T'Range loop
286
         if At_EOF then
287
            P := Save_P;
288
            return False;
289
         end if;
290
 
291
         C := S (P);
292
 
293
         if C in 'A' .. 'Z' then
294
            C := Character'Val (Character'Pos (C) +
295
                                 (Character'Pos ('a') - Character'Pos ('A')));
296
         end if;
297
 
298
         if C /= T (K) then
299
            P := Save_P;
300
            return False;
301
         end if;
302
 
303
         P := P + 1;
304
      end loop;
305
 
306
      if At_EOF then
307
         return True;
308
      end if;
309
 
310
      C := S (P);
311
 
312
      if C in '0' .. '9'
313
        or else C in 'a' .. 'z'
314
        or else C in 'A' .. 'Z'
315
        or else C > Character'Val (127)
316
      then
317
         P := Save_P;
318
         return False;
319
 
320
      else
321
         return True;
322
      end if;
323
   end Check_Token;
324
 
325
   -----------
326
   -- Error --
327
   -----------
328
 
329
   procedure Error (Err : String) is
330
      C : Natural := 0;
331
      --  Column number
332
 
333
      M : String (1 .. 80);
334
      --  Buffer used to build resulting error msg
335
 
336
      LM : Natural := 0;
337
      --  Pointer to last set location in M
338
 
339
      procedure Add_Nat (N : Natural);
340
      --  Add chars of integer to error msg buffer
341
 
342
      -------------
343
      -- Add_Nat --
344
      -------------
345
 
346
      procedure Add_Nat (N : Natural) is
347
      begin
348
         if N > 9 then
349
            Add_Nat (N / 10);
350
         end if;
351
 
352
         LM := LM + 1;
353
         M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
354
      end Add_Nat;
355
 
356
   --  Start of processing for Error
357
 
358
   begin
359
      M (1 .. 9) := "gnat.adc:";
360
      LM := 9;
361
      Add_Nat (Line_Num);
362
      LM := LM + 1;
363
      M (LM) := ':';
364
 
365
      --  Determine column number
366
 
367
      for X in Start_Of_Line .. P loop
368
         C := C + 1;
369
 
370
         if S (X) = HT then
371
            C := (C + 7) / 8 * 8;
372
         end if;
373
      end loop;
374
 
375
      Add_Nat (C);
376
      M (LM + 1) := ':';
377
      LM := LM + 1;
378
      M (LM + 1) := ' ';
379
      LM := LM + 1;
380
 
381
      M (LM + 1 .. LM + Err'Length) := Err;
382
      LM := LM + Err'Length;
383
 
384
      Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
385
   end Error;
386
 
387
   -------------------
388
   -- Require_Token --
389
   -------------------
390
 
391
   procedure Require_Token (T : String) is
392
      SaveP : Natural;
393
 
394
   begin
395
      Skip_WS;
396
      SaveP := P;
397
 
398
      for J in T'Range loop
399
 
400
         if At_EOF or else S (P) /= T (J) then
401
            declare
402
               S : String (1 .. T'Length + 10);
403
 
404
            begin
405
               S (1 .. 9) := "missing """;
406
               S (10 .. T'Length + 9) := T;
407
               S (T'Length + 10) := '"';
408
               P := SaveP;
409
               Error (S);
410
            end;
411
 
412
         else
413
            P := P + 1;
414
         end if;
415
      end loop;
416
   end Require_Token;
417
 
418
   ----------------------
419
   -- Scan_SFN_Pragmas --
420
   ----------------------
421
 
422
   procedure Scan_SFN_Pragmas
423
     (Source   : String;
424
      SFN_Ptr  : Set_File_Name_Ptr;
425
      SFNP_Ptr : Set_File_Name_Pattern_Ptr)
426
   is
427
      B, E : Natural;
428
      Typ  : Character;
429
      Cas  : Character;
430
 
431
   begin
432
      Line_Num := 1;
433
      S := Source'Unrestricted_Access;
434
      P := Source'First;
435
      Start_Of_Line := P;
436
 
437
      --  Loop through pragmas in file
438
 
439
      Main_Scan_Loop : loop
440
         Skip_WS;
441
         exit Main_Scan_Loop when At_EOF;
442
 
443
         --  Error if something other than pragma
444
 
445
         if not Check_Token ("pragma") then
446
            Error ("non pragma encountered");
447
         end if;
448
 
449
         --  Source_File_Name pragma case
450
 
451
         if Check_Token ("source_file_name")
452
              or else
453
             Check_Token ("source_file_name_project")
454
         then
455
            Require_Token ("(");
456
 
457
            Typ := Check_File_Type;
458
 
459
            --  First format, with unit name first
460
 
461
            if Typ = ' ' then
462
               if Check_Token ("unit_name") then
463
                  Require_Token ("=>");
464
               end if;
465
 
466
               declare
467
                  U : constant String := Acquire_Unit_Name;
468
 
469
               begin
470
                  Require_Token (",");
471
                  Typ := Check_File_Type;
472
 
473
                  if Typ /= 's' and then Typ /= 'b' then
474
                     Error ("bad pragma");
475
                  end if;
476
 
477
                  Require_Token ("=>");
478
                  Scan_String (B, E);
479
 
480
                  declare
481
                     F : constant String := Acquire_String (B, E);
482
                     X : Natural;
483
 
484
                  begin
485
                     --  Scan Index parameter if present
486
 
487
                     if Check_Token (",") then
488
                        if Check_Token ("index") then
489
                           Require_Token ("=>");
490
                        end if;
491
 
492
                        X := Acquire_Integer;
493
                     else
494
                        X := 0;
495
                     end if;
496
 
497
                     Require_Token (")");
498
                     Require_Token (";");
499
                     SFN_Ptr.all (Typ, U, F, X);
500
                  end;
501
               end;
502
 
503
            --  Second format with pattern string
504
 
505
            else
506
               Require_Token ("=>");
507
               Scan_String (B, E);
508
 
509
               declare
510
                  Pat : constant String := Acquire_String (B, E);
511
                  Nas : Natural := 0;
512
 
513
               begin
514
                  --  Check exactly one asterisk
515
 
516
                  for J in Pat'Range loop
517
                     if Pat (J) = '*' then
518
                        Nas := Nas + 1;
519
                     end if;
520
                  end loop;
521
 
522
                  if Nas /= 1 then
523
                     Error ("** not allowed");
524
                  end if;
525
 
526
                  B := 0;
527
                  E := 0;
528
                  Cas := ' ';
529
 
530
                  --  Loop to scan out Casing or Dot_Replacement parameters
531
 
532
                  loop
533
                     Check_Not_At_EOF;
534
                     exit when S (P) = ')';
535
                     Require_Token (",");
536
 
537
                     if Check_Token ("casing") then
538
                        Require_Token ("=>");
539
 
540
                        if Cas /= ' ' then
541
                           Error ("duplicate casing argument");
542
                        elsif Check_Token ("lowercase") then
543
                           Cas := 'l';
544
                        elsif Check_Token ("uppercase") then
545
                           Cas := 'u';
546
                        elsif Check_Token ("mixedcase") then
547
                           Cas := 'm';
548
                        else
549
                           Error ("invalid casing argument");
550
                        end if;
551
 
552
                     elsif Check_Token ("dot_replacement") then
553
                        Require_Token ("=>");
554
 
555
                        if E /= 0 then
556
                           Error ("duplicate dot_replacement");
557
                        else
558
                           Scan_String (B, E);
559
                        end if;
560
 
561
                     else
562
                        Error ("invalid argument");
563
                     end if;
564
                  end loop;
565
 
566
                  Require_Token (")");
567
                  Require_Token (";");
568
 
569
                  if Cas = ' ' then
570
                     Cas := 'l';
571
                  end if;
572
 
573
                  if E = 0 then
574
                     SFNP_Ptr.all (Pat, Typ, ".", Cas);
575
 
576
                  else
577
                     declare
578
                        Dot : constant String := Acquire_String (B, E);
579
 
580
                     begin
581
                        SFNP_Ptr.all (Pat, Typ, Dot, Cas);
582
                     end;
583
                  end if;
584
               end;
585
            end if;
586
 
587
         --  Some other pragma, scan to semicolon at end of pragma
588
 
589
         else
590
            Skip_Loop : loop
591
               exit Main_Scan_Loop when At_EOF;
592
               exit Skip_Loop when S (P) = ';';
593
 
594
               if S (P) = '"' or else S (P) = '%' then
595
                  Scan_String (B, E);
596
               else
597
                  P := P + 1;
598
               end if;
599
            end loop Skip_Loop;
600
 
601
            --  We successfully skipped to semicolon, so skip past it
602
 
603
            P := P + 1;
604
         end if;
605
      end loop Main_Scan_Loop;
606
 
607
   exception
608
      when others =>
609
         Cursor := P - S'First + 1;
610
         raise;
611
   end Scan_SFN_Pragmas;
612
 
613
   -----------------
614
   -- Scan_String --
615
   -----------------
616
 
617
   procedure Scan_String (B : out Natural; E : out Natural) is
618
      Q : Character;
619
 
620
   begin
621
      Check_Not_At_EOF;
622
 
623
      if S (P) = '"' then
624
         Q := '"';
625
      elsif S (P) = '%' then
626
         Q := '%';
627
      else
628
         Error ("bad string");
629
         Q := '"';
630
      end if;
631
 
632
      --  Scan out the string, B points to first char
633
 
634
      B := P;
635
      P := P + 1;
636
 
637
      loop
638
         if At_EOF or else S (P) = LF or else S (P) = CR then
639
            Error -- CODEFIX
640
              ("missing string quote");
641
 
642
         elsif S (P) = HT then
643
            Error ("tab character in string");
644
 
645
         elsif S (P) /= Q then
646
            P := P + 1;
647
 
648
         --  We have a quote
649
 
650
         else
651
            P := P + 1;
652
 
653
            --  Check for doubled quote
654
 
655
            if not At_EOF and then S (P) = Q then
656
               P := P + 1;
657
 
658
            --  Otherwise this is the terminating quote
659
 
660
            else
661
               E := P - 1;
662
               return;
663
            end if;
664
         end if;
665
      end loop;
666
   end Scan_String;
667
 
668
   -------------
669
   -- Skip_WS --
670
   -------------
671
 
672
   procedure Skip_WS is
673
   begin
674
      WS_Scan : while not At_EOF loop
675
         case S (P) is
676
 
677
            --  End of physical line
678
 
679
            when CR | LF =>
680
               Line_Num := Line_Num + 1;
681
               P := P + 1;
682
 
683
               while not At_EOF
684
                 and then (S (P) = CR or else S (P) = LF)
685
               loop
686
                  Line_Num := Line_Num + 1;
687
                  P := P + 1;
688
               end loop;
689
 
690
               Start_Of_Line := P;
691
 
692
            --  All other cases of white space characters
693
 
694
            when ' ' | FF | VT | HT =>
695
               P := P + 1;
696
 
697
            --  Comment
698
 
699
            when '-' =>
700
               P := P + 1;
701
 
702
               if At_EOF then
703
                  Error ("bad comment");
704
 
705
               elsif S (P) = '-' then
706
                  P := P + 1;
707
 
708
                  while not At_EOF loop
709
                     case S (P) is
710
                        when CR | LF | FF | VT =>
711
                           exit;
712
                        when others =>
713
                           P := P + 1;
714
                     end case;
715
                  end loop;
716
 
717
               else
718
                  P := P - 1;
719
                  exit WS_Scan;
720
               end if;
721
 
722
            when others =>
723
               exit WS_Scan;
724
 
725
         end case;
726
      end loop WS_Scan;
727
   end Skip_WS;
728
 
729
end SFN_Scan;

powered by: WebSVN 2.1.0

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