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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                          GNAT SYSTEM UTILITIES                           --
4
--                                                                          --
5
--                               C S I N F O                                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-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.  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 COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
--  Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
27
--  is consistent and that assertion cross-reference lists are correct, as well
28
--  as making sure that all the comments on field name usage are consistent.
29
 
30
--  Note that this is used both as a standalone program, and as a procedure
31
--  called by XSinfo. This raises an unhandled exception if it finds any
32
--  errors; we don't attempt any sophisticated error recovery.
33
 
34
with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
35
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
36
with Ada.Strings.Maps;              use Ada.Strings.Maps;
37
with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
38
with Ada.Text_IO;                   use Ada.Text_IO;
39
 
40
with GNAT.Spitbol;                  use GNAT.Spitbol;
41
with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
42
with GNAT.Spitbol.Table_Boolean;
43
with GNAT.Spitbol.Table_VString;
44
 
45
procedure CSinfo is
46
 
47
   package TB renames GNAT.Spitbol.Table_Boolean;
48
   package TV renames GNAT.Spitbol.Table_VString;
49
   use TB, TV;
50
 
51
   Infil  : File_Type;
52
   Lineno : Natural := 0;
53
 
54
   Err : exception;
55
   --  Raised on fatal error
56
 
57
   Done : exception;
58
   --  Raised after error is found to terminate run
59
 
60
   WSP : constant Pattern := Span (' ' & ASCII.HT);
61
 
62
   Fields   : TV.Table (300);
63
   Fields1  : TV.Table (300);
64
   Refs     : TV.Table (300);
65
   Refscopy : TV.Table (300);
66
   Special  : TB.Table (50);
67
   Inlines  : TV.Table (100);
68
 
69
   --  The following define the standard fields used for binary operator,
70
   --  unary operator, and other expression nodes. Numbers in the range 1-5
71
   --  refer to the Fieldn fields. Letters D-R refer to flags:
72
 
73
   --      D = Flag4
74
   --      E = Flag5
75
   --      F = Flag6
76
   --      G = Flag7
77
   --      H = Flag8
78
   --      I = Flag9
79
   --      J = Flag10
80
   --      K = Flag11
81
   --      L = Flag12
82
   --      M = Flag13
83
   --      N = Flag14
84
   --      O = Flag15
85
   --      P = Flag16
86
   --      Q = Flag17
87
   --      R = Flag18
88
 
89
   Flags : TV.Table (20);
90
   --  Maps flag numbers to letters
91
 
92
   N_Fields : constant Pattern := BreakX ("JL");
93
   E_Fields : constant Pattern := BreakX ("5EFGHIJLOP");
94
   U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ");
95
   B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ");
96
 
97
   Line : VString;
98
   Bad  : Boolean;
99
 
100
   Field       : constant VString := Nul;
101
   Fields_Used : VString := Nul;
102
   Name        : constant VString := Nul;
103
   Next        : constant VString := Nul;
104
   Node        : VString := Nul;
105
   Ref         : VString := Nul;
106
   Synonym     : constant VString := Nul;
107
   Nxtref      : constant VString := Nul;
108
 
109
   Which_Field : aliased VString := Nul;
110
 
111
   Node_Search : constant Pattern := WSP & "--  N_" & Rest * Node;
112
   Break_Punc  : constant Pattern := Break (" .,");
113
   Plus_Binary : constant Pattern := WSP
114
                                     & "--  plus fields for binary operator";
115
   Plus_Unary  : constant Pattern := WSP
116
                                     & "--  plus fields for unary operator";
117
   Plus_Expr   : constant Pattern := WSP
118
                                     & "--  plus fields for expression";
119
   Break_Syn   : constant Pattern := WSP &  "--  "
120
                                     & Break (' ') * Synonym
121
                                     & " (" & Break (')') * Field;
122
   Break_Field : constant Pattern := BreakX ('-') * Field;
123
   Get_Field   : constant Pattern := BreakX (Decimal_Digit_Set)
124
                                     & Span (Decimal_Digit_Set) * Which_Field;
125
   Break_WFld  : constant Pattern := Break (Which_Field'Access);
126
   Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
127
   Extr_Field  : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
128
   Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
129
   Get_Inline  : constant Pattern := WSP & "pragma Inline ("
130
                                     & Break (')') * Name;
131
   Set_Name    : constant Pattern := "Set_" & Rest * Name;
132
   Func_Rest   : constant Pattern := "   function " & Rest * Synonym;
133
   Get_Nxtref  : constant Pattern := Break (',') * Nxtref & ',';
134
   Test_Syn    : constant Pattern := Break ('=') & "= N_"
135
                                     & (Break (" ,)") or Rest) * Next;
136
   Chop_Comma  : constant Pattern := BreakX (',') * Next;
137
   Return_Fld  : constant Pattern := WSP & "return " & Break (' ') * Field;
138
   Set_Syn     : constant Pattern := "   procedure Set_" & Rest * Synonym;
139
   Set_Fld     : constant Pattern := WSP & "Set_" & Break (' ') * Field
140
                                     & " (N, Val)";
141
   Break_With  : constant Pattern := Break ('_') ** Field & "_With_Parent";
142
 
143
   type VStringA is array (Natural range <>) of VString;
144
 
145
   procedure Next_Line;
146
   --  Read next line trimmed from Infil into Line and bump Lineno
147
 
148
   procedure Sort (A : in out VStringA);
149
   --  Sort a (small) array of VString's
150
 
151
   procedure Next_Line is
152
   begin
153
      Line := Get_Line (Infil);
154
      Trim (Line);
155
      Lineno := Lineno + 1;
156
   end Next_Line;
157
 
158
   procedure Sort (A : in out VStringA) is
159
      Temp : VString;
160
   begin
161
      <<Sort>>
162
         for J in 1 .. A'Length - 1 loop
163
            if A (J) > A (J + 1) then
164
               Temp := A (J);
165
               A (J) := A (J + 1);
166
               A (J + 1) := Temp;
167
               goto Sort;
168
            end if;
169
         end loop;
170
   end Sort;
171
 
172
--  Start of processing for CSinfo
173
 
174
begin
175
   Anchored_Mode := True;
176
   New_Line;
177
   Open (Infil, In_File, "sinfo.ads");
178
   Put_Line ("Check for field name consistency");
179
 
180
   --  Setup table for mapping flag numbers to letters
181
 
182
   Set (Flags, "4",  V ("D"));
183
   Set (Flags, "5",  V ("E"));
184
   Set (Flags, "6",  V ("F"));
185
   Set (Flags, "7",  V ("G"));
186
   Set (Flags, "8",  V ("H"));
187
   Set (Flags, "9",  V ("I"));
188
   Set (Flags, "10", V ("J"));
189
   Set (Flags, "11", V ("K"));
190
   Set (Flags, "12", V ("L"));
191
   Set (Flags, "13", V ("M"));
192
   Set (Flags, "14", V ("N"));
193
   Set (Flags, "15", V ("O"));
194
   Set (Flags, "16", V ("P"));
195
   Set (Flags, "17", V ("Q"));
196
   Set (Flags, "18", V ("R"));
197
 
198
   --  Special fields table. The following names are not recorded or checked
199
   --  by Csinfo, since they are specially handled. This means that any field
200
   --  definition or subprogram with a matching name is ignored.
201
 
202
   Set (Special, "Analyzed",                  True);
203
   Set (Special, "Assignment_OK",             True);
204
   Set (Special, "Associated_Node",           True);
205
   Set (Special, "Cannot_Be_Constant",        True);
206
   Set (Special, "Chars",                     True);
207
   Set (Special, "Comes_From_Source",         True);
208
   Set (Special, "Do_Overflow_Check",         True);
209
   Set (Special, "Do_Range_Check",            True);
210
   Set (Special, "Entity",                    True);
211
   Set (Special, "Entity_Or_Associated_Node", True);
212
   Set (Special, "Error_Posted",              True);
213
   Set (Special, "Etype",                     True);
214
   Set (Special, "Evaluate_Once",             True);
215
   Set (Special, "First_Itype",               True);
216
   Set (Special, "Has_Aspect_Specifications", True);
217
   Set (Special, "Has_Dynamic_Itype",         True);
218
   Set (Special, "Has_Dynamic_Range_Check",   True);
219
   Set (Special, "Has_Dynamic_Length_Check",  True);
220
   Set (Special, "Has_Private_View",          True);
221
   Set (Special, "Is_Controlling_Actual",     True);
222
   Set (Special, "Is_Overloaded",             True);
223
   Set (Special, "Is_Static_Expression",      True);
224
   Set (Special, "Left_Opnd",                 True);
225
   Set (Special, "Must_Not_Freeze",           True);
226
   Set (Special, "Nkind_In",                  True);
227
   Set (Special, "Parens",                    True);
228
   Set (Special, "Pragma_Name",               True);
229
   Set (Special, "Raises_Constraint_Error",   True);
230
   Set (Special, "Right_Opnd",                True);
231
 
232
   --  Loop to acquire information from node definitions in sinfo.ads,
233
   --  checking for consistency in Op/Flag assignments to each synonym
234
 
235
   loop
236
      Bad := False;
237
      Next_Line;
238
      exit when Match (Line, "   -- Node Access Functions");
239
 
240
      if Match (Line, Node_Search)
241
        and then not Match (Node, Break_Punc)
242
      then
243
         Fields_Used := Nul;
244
 
245
      elsif Node = "" then
246
         null;
247
 
248
      elsif Line = "" then
249
         Node := Nul;
250
 
251
      elsif Match (Line, Plus_Binary) then
252
         Bad := Match (Fields_Used, B_Fields);
253
 
254
      elsif Match (Line, Plus_Unary) then
255
         Bad := Match (Fields_Used, U_Fields);
256
 
257
      elsif Match (Line, Plus_Expr) then
258
         Bad := Match (Fields_Used, E_Fields);
259
 
260
      elsif not Match (Line, Break_Syn) then
261
         null;
262
 
263
      elsif Match (Synonym, "plus") then
264
         null;
265
 
266
      else
267
         Match (Field, Break_Field);
268
 
269
         if not Present (Special, Synonym) then
270
            if Present (Fields, Synonym) then
271
               if Field /= Get (Fields, Synonym) then
272
                  Put_Line
273
                    ("Inconsistent field reference at line" &
274
                     Lineno'Img & " for " & Synonym);
275
                  raise Done;
276
               end if;
277
 
278
            else
279
               Set (Fields, Synonym, Field);
280
            end if;
281
 
282
            Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
283
            Match (Field, Get_Field);
284
 
285
            if Match (Field, "Flag") then
286
               Which_Field := Get (Flags, Which_Field);
287
            end if;
288
 
289
            if Match (Fields_Used, Break_WFld) then
290
               Put_Line
291
                 ("Overlapping field at line " & Lineno'Img &
292
                  " for " & Synonym);
293
               raise Done;
294
            end if;
295
 
296
            Append (Fields_Used, Which_Field);
297
            Bad := Bad or Match (Fields_Used, N_Fields);
298
         end if;
299
      end if;
300
 
301
      if Bad then
302
         Put_Line ("fields conflict with standard fields for node " & Node);
303
         raise Done;
304
      end if;
305
   end loop;
306
 
307
   Put_Line ("     OK");
308
   New_Line;
309
   Put_Line ("Check for function consistency");
310
 
311
   --  Loop through field function definitions to make sure they are OK
312
 
313
   Fields1 := Fields;
314
   loop
315
      Next_Line;
316
      exit when Match (Line, "   -- Node Update");
317
 
318
      if Match (Line, Get_Funcsyn)
319
        and then not Present (Special, Synonym)
320
      then
321
         if not Present (Fields1, Synonym) then
322
            Put_Line
323
              ("function on line " &  Lineno &
324
               " is for unused synonym");
325
            raise Done;
326
         end if;
327
 
328
         Next_Line;
329
 
330
         if not Match (Line, Extr_Field) then
331
            raise Err;
332
         end if;
333
 
334
         if Field /= Get (Fields1, Synonym) then
335
            Put_Line ("Wrong field in function " & Synonym);
336
            raise Done;
337
 
338
         else
339
            Delete (Fields1, Synonym);
340
         end if;
341
      end if;
342
   end loop;
343
 
344
   Put_Line ("     OK");
345
   New_Line;
346
   Put_Line ("Check for missing functions");
347
 
348
   declare
349
      List : constant TV.Table_Array := Convert_To_Array (Fields1);
350
 
351
   begin
352
      if List'Length > 0 then
353
         Put_Line ("No function for field synonym " & List (1).Name);
354
         raise Done;
355
      end if;
356
   end;
357
 
358
   --  Check field set procedures
359
 
360
   Put_Line ("     OK");
361
   New_Line;
362
   Put_Line ("Check for set procedure consistency");
363
 
364
   Fields1 := Fields;
365
   loop
366
      Next_Line;
367
      exit when Match (Line, "   -- Inline Pragmas");
368
      exit when Match (Line, "   -- Iterator Procedures");
369
 
370
      if Match (Line, Get_Procsyn)
371
        and then not Present (Special, Synonym)
372
      then
373
         if not Present (Fields1, Synonym) then
374
            Put_Line
375
              ("procedure on line " & Lineno & " is for unused synonym");
376
            raise Done;
377
         end if;
378
 
379
         Next_Line;
380
 
381
         if not Match (Line, Extr_Field) then
382
            raise Err;
383
         end if;
384
 
385
         if Field /= Get (Fields1, Synonym) then
386
            Put_Line ("Wrong field in procedure Set_" & Synonym);
387
            raise Done;
388
 
389
         else
390
            Delete (Fields1, Synonym);
391
         end if;
392
      end if;
393
   end loop;
394
 
395
   Put_Line ("     OK");
396
   New_Line;
397
   Put_Line ("Check for missing set procedures");
398
 
399
   declare
400
      List : constant TV.Table_Array := Convert_To_Array (Fields1);
401
 
402
   begin
403
      if List'Length > 0 then
404
         Put_Line ("No procedure for field synonym Set_" & List (1).Name);
405
         raise Done;
406
      end if;
407
   end;
408
 
409
   Put_Line ("     OK");
410
   New_Line;
411
   Put_Line ("Check pragma Inlines are all for existing subprograms");
412
 
413
   Clear (Fields1);
414
   while not End_Of_File (Infil) loop
415
      Next_Line;
416
 
417
      if Match (Line, Get_Inline)
418
        and then not Present (Special, Name)
419
      then
420
         exit when Match (Name, Set_Name);
421
 
422
         if not Present (Fields, Name) then
423
            Put_Line
424
              ("Pragma Inline on line " & Lineno &
425
               " does not correspond to synonym");
426
            raise Done;
427
 
428
         else
429
            Set (Inlines, Name, Get (Inlines, Name) & 'r');
430
         end if;
431
      end if;
432
   end loop;
433
 
434
   Put_Line ("     OK");
435
   New_Line;
436
   Put_Line ("Check no pragma Inlines were omitted");
437
 
438
   declare
439
      List : constant TV.Table_Array := Convert_To_Array (Fields);
440
      Nxt  : VString := Nul;
441
 
442
   begin
443
      for M in List'Range loop
444
         Nxt := List (M).Name;
445
 
446
         if Get (Inlines, Nxt) /= "r" then
447
            Put_Line ("Incorrect pragma Inlines for " & Nxt);
448
            raise Done;
449
         end if;
450
      end loop;
451
   end;
452
 
453
   Put_Line ("     OK");
454
   New_Line;
455
   Clear (Inlines);
456
 
457
   Close (Infil);
458
   Open (Infil, In_File, "sinfo.adb");
459
   Lineno := 0;
460
   Put_Line ("Check references in functions in body");
461
 
462
   Refscopy := Refs;
463
   loop
464
      Next_Line;
465
      exit when Match (Line, "   -- Field Access Functions --");
466
   end loop;
467
 
468
   loop
469
      Next_Line;
470
      exit when Match (Line, "   -- Field Set Procedures --");
471
 
472
      if Match (Line, Func_Rest)
473
        and then not Present (Special, Synonym)
474
      then
475
         Ref := Get (Refs, Synonym);
476
         Delete (Refs, Synonym);
477
 
478
         if Ref = "" then
479
            Put_Line
480
              ("Function on line " & Lineno & " is for unknown synonym");
481
            raise Err;
482
         end if;
483
 
484
         --  Alpha sort of references for this entry
485
 
486
         declare
487
            Refa   : VStringA (1 .. 100);
488
            N      : Natural := 0;
489
 
490
         begin
491
            loop
492
               exit when not Match (Ref, Get_Nxtref, Nul);
493
               N := N + 1;
494
               Refa (N) := Nxtref;
495
            end loop;
496
 
497
            Sort (Refa (1 .. N));
498
            Next_Line;
499
            Next_Line;
500
            Next_Line;
501
 
502
            --  Checking references for one entry
503
 
504
            for M in 1 .. N loop
505
               Next_Line;
506
 
507
               if not Match (Line, Test_Syn) then
508
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
509
                  raise Done;
510
               end if;
511
 
512
               Match (Next, Chop_Comma);
513
 
514
               if Next /= Refa (M) then
515
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
516
                  raise Done;
517
               end if;
518
            end loop;
519
 
520
            Next_Line;
521
            Match (Line, Return_Fld);
522
 
523
            if Field /= Get (Fields, Synonym) then
524
               Put_Line
525
                ("Wrong field for function " & Synonym & " at line " &
526
                 Lineno & " should be " & Get (Fields, Synonym));
527
               raise Done;
528
            end if;
529
         end;
530
      end if;
531
   end loop;
532
 
533
   Put_Line ("     OK");
534
   New_Line;
535
   Put_Line ("Check for missing functions in body");
536
 
537
   declare
538
      List : constant TV.Table_Array := Convert_To_Array (Refs);
539
 
540
   begin
541
      if List'Length /= 0 then
542
         Put_Line ("Missing function " & List (1).Name & " in body");
543
         raise Done;
544
      end if;
545
   end;
546
 
547
   Put_Line ("     OK");
548
   New_Line;
549
   Put_Line ("Check Set procedures in body");
550
   Refs := Refscopy;
551
 
552
   loop
553
      Next_Line;
554
      exit when Match (Line, "end");
555
      exit when Match (Line, "   -- Iterator Procedures");
556
 
557
      if Match (Line, Set_Syn)
558
        and then not Present (Special, Synonym)
559
      then
560
         Ref := Get (Refs, Synonym);
561
         Delete (Refs, Synonym);
562
 
563
         if Ref = "" then
564
            Put_Line
565
              ("Function on line " & Lineno & " is for unknown synonym");
566
            raise Err;
567
         end if;
568
 
569
         --  Alpha sort of references for this entry
570
 
571
         declare
572
            Refa   : VStringA (1 .. 100);
573
            N      : Natural;
574
 
575
         begin
576
            N := 0;
577
 
578
            loop
579
               exit when not Match (Ref, Get_Nxtref, Nul);
580
               N := N + 1;
581
               Refa (N) := Nxtref;
582
            end loop;
583
 
584
            Sort (Refa (1 .. N));
585
 
586
            Next_Line;
587
            Next_Line;
588
            Next_Line;
589
 
590
            --  Checking references for one entry
591
 
592
            for M in 1 .. N loop
593
               Next_Line;
594
 
595
               if not Match (Line, Test_Syn)
596
                 or else Next /= Refa (M)
597
               then
598
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
599
                  raise Err;
600
               end if;
601
            end loop;
602
 
603
            loop
604
               Next_Line;
605
               exit when Match (Line, Set_Fld);
606
            end loop;
607
 
608
            Match (Field, Break_With);
609
 
610
            if Field /= Get (Fields, Synonym) then
611
               Put_Line
612
                 ("Wrong field for procedure Set_" & Synonym &
613
                  " at line " & Lineno & " should be " &
614
                  Get (Fields, Synonym));
615
               raise Done;
616
            end if;
617
 
618
            Delete (Fields1, Synonym);
619
         end;
620
      end if;
621
   end loop;
622
 
623
   Put_Line ("     OK");
624
   New_Line;
625
   Put_Line ("Check for missing set procedures in body");
626
 
627
   declare
628
      List : constant TV.Table_Array := Convert_To_Array (Fields1);
629
 
630
   begin
631
      if List'Length /= 0 then
632
         Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
633
         raise Done;
634
      end if;
635
   end;
636
 
637
   Put_Line ("     OK");
638
   New_Line;
639
   Put_Line ("All tests completed successfully, no errors detected");
640
 
641
end CSinfo;

powered by: WebSVN 2.1.0

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