aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/csinfo.adb
blob: 1a71a2ef6db955deb34aa6b1c51ee09faa9089f1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
------------------------------------------------------------------------------
--                                                                          --
--                          GNAT SYSTEM UTILITIES                           --
--                                                                          --
--                               C S I N F O                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
--  is consistent and that assertion cross-reference lists are correct, as well
--  as making sure that all the comments on field name usage are consistent.

--  Note that this is used both as a standalone program, and as a procedure
--  called by XSinfo. This raises an unhandled exception if it finds any
--  errors; we don't attempt any sophisticated error recovery.

with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
with Ada.Strings.Maps;              use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
with Ada.Text_IO;                   use Ada.Text_IO;

with GNAT.Spitbol;                  use GNAT.Spitbol;
with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
with GNAT.Spitbol.Table_Boolean;
with GNAT.Spitbol.Table_VString;

procedure CSinfo is

   package TB renames GNAT.Spitbol.Table_Boolean;
   package TV renames GNAT.Spitbol.Table_VString;
   use TB, TV;

   Infil  : File_Type;
   Lineno : Natural := 0;

   Err : exception;
   --  Raised on fatal error

   Done : exception;
   --  Raised after error is found to terminate run

   WSP : constant Pattern := Span (' ' & ASCII.HT);

   Fields   : TV.Table (300);
   Fields1  : TV.Table (300);
   Refs     : TV.Table (300);
   Refscopy : TV.Table (300);
   Special  : TB.Table (50);
   Inlines  : TV.Table (100);

   --  The following define the standard fields used for binary operator,
   --  unary operator, and other expression nodes. Numbers in the range 1-5
   --  refer to the Fieldn fields. Letters D-R refer to flags:

   --      D = Flag4
   --      E = Flag5
   --      F = Flag6
   --      G = Flag7
   --      H = Flag8
   --      I = Flag9
   --      J = Flag10
   --      K = Flag11
   --      L = Flag12
   --      M = Flag13
   --      N = Flag14
   --      O = Flag15
   --      P = Flag16
   --      Q = Flag17
   --      R = Flag18

   Flags : TV.Table (20);
   --  Maps flag numbers to letters

   N_Fields : constant Pattern := BreakX ("JL");
   E_Fields : constant Pattern := BreakX ("5EFGHIJLOP");
   U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ");
   B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ");

   Line : VString;
   Bad  : Boolean;

   Field       : constant VString := Nul;
   Fields_Used : VString := Nul;
   Name        : constant VString := Nul;
   Next        : constant VString := Nul;
   Node        : VString := Nul;
   Ref         : VString := Nul;
   Synonym     : constant VString := Nul;
   Nxtref      : constant VString := Nul;

   Which_Field : aliased VString := Nul;

   Node_Search : constant Pattern := WSP & "--  N_" & Rest * Node;
   Break_Punc  : constant Pattern := Break (" .,");
   Plus_Binary : constant Pattern := WSP
                                     & "--  plus fields for binary operator";
   Plus_Unary  : constant Pattern := WSP
                                     & "--  plus fields for unary operator";
   Plus_Expr   : constant Pattern := WSP
                                     & "--  plus fields for expression";
   Break_Syn   : constant Pattern := WSP &  "--  "
                                     & Break (' ') * Synonym
                                     & " (" & Break (')') * Field;
   Break_Field : constant Pattern := BreakX ('-') * Field;
   Get_Field   : constant Pattern := BreakX (Decimal_Digit_Set)
                                     & Span (Decimal_Digit_Set) * Which_Field;
   Break_WFld  : constant Pattern := Break (Which_Field'Access);
   Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
   Extr_Field  : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
   Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
   Get_Inline  : constant Pattern := WSP & "pragma Inline ("
                                     & Break (')') * Name;
   Set_Name    : constant Pattern := "Set_" & Rest * Name;
   Func_Rest   : constant Pattern := "   function " & Rest * Synonym;
   Get_Nxtref  : constant Pattern := Break (',') * Nxtref & ',';
   Test_Syn    : constant Pattern := Break ('=') & "= N_"
                                     & (Break (" ,)") or Rest) * Next;
   Chop_Comma  : constant Pattern := BreakX (',') * Next;
   Return_Fld  : constant Pattern := WSP & "return " & Break (' ') * Field;
   Set_Syn     : constant Pattern := "   procedure Set_" & Rest * Synonym;
   Set_Fld     : constant Pattern := WSP & "Set_" & Break (' ') * Field
                                     & " (N, Val)";
   Break_With  : constant Pattern := Break ('_') ** Field & "_With_Parent";

   type VStringA is array (Natural range <>) of VString;

   procedure Next_Line;
   --  Read next line trimmed from Infil into Line and bump Lineno

   procedure Sort (A : in out VStringA);
   --  Sort a (small) array of VString's

   procedure Next_Line is
   begin
      Line := Get_Line (Infil);
      Trim (Line);
      Lineno := Lineno + 1;
   end Next_Line;

   procedure Sort (A : in out VStringA) is
      Temp : VString;
   begin
      <<Sort>>
         for J in 1 .. A'Length - 1 loop
            if A (J) > A (J + 1) then
               Temp := A (J);
               A (J) := A (J + 1);
               A (J + 1) := Temp;
               goto Sort;
            end if;
         end loop;
   end Sort;

--  Start of processing for CSinfo

begin
   Anchored_Mode := True;
   New_Line;
   Open (Infil, In_File, "sinfo.ads");
   Put_Line ("Check for field name consistency");

   --  Setup table for mapping flag numbers to letters

   Set (Flags, "4",  V ("D"));
   Set (Flags, "5",  V ("E"));
   Set (Flags, "6",  V ("F"));
   Set (Flags, "7",  V ("G"));
   Set (Flags, "8",  V ("H"));
   Set (Flags, "9",  V ("I"));
   Set (Flags, "10", V ("J"));
   Set (Flags, "11", V ("K"));
   Set (Flags, "12", V ("L"));
   Set (Flags, "13", V ("M"));
   Set (Flags, "14", V ("N"));
   Set (Flags, "15", V ("O"));
   Set (Flags, "16", V ("P"));
   Set (Flags, "17", V ("Q"));
   Set (Flags, "18", V ("R"));

   --  Special fields table. The following names are not recorded or checked
   --  by Csinfo, since they are specially handled. This means that any field
   --  definition or subprogram with a matching name is ignored.

   Set (Special, "Analyzed",                         True);
   Set (Special, "Assignment_OK",                    True);
   Set (Special, "Associated_Node",                  True);
   Set (Special, "Cannot_Be_Constant",               True);
   Set (Special, "Chars",                            True);
   Set (Special, "Comes_From_Source",                True);
   Set (Special, "Do_Overflow_Check",                True);
   Set (Special, "Do_Range_Check",                   True);
   Set (Special, "Entity",                           True);
   Set (Special, "Entity_Or_Associated_Node",        True);
   Set (Special, "Error_Posted",                     True);
   Set (Special, "Etype",                            True);
   Set (Special, "Evaluate_Once",                    True);
   Set (Special, "First_Itype",                      True);
   Set (Special, "Has_Aspect_Specifications",        True);
   Set (Special, "Has_Dynamic_Itype",                True);
   Set (Special, "Has_Dynamic_Range_Check",          True);
   Set (Special, "Has_Dynamic_Length_Check",         True);
   Set (Special, "Has_Private_View",                 True);
   Set (Special, "Implicit_With_From_Instantiation", True);
   Set (Special, "Is_Controlling_Actual",            True);
   Set (Special, "Is_Overloaded",                    True);
   Set (Special, "Is_Static_Expression",             True);
   Set (Special, "Left_Opnd",                        True);
   Set (Special, "Must_Not_Freeze",                  True);
   Set (Special, "Nkind_In",                         True);
   Set (Special, "Parens",                           True);
   Set (Special, "Pragma_Name",                      True);
   Set (Special, "Raises_Constraint_Error",          True);
   Set (Special, "Right_Opnd",                       True);

   --  Loop to acquire information from node definitions in sinfo.ads,
   --  checking for consistency in Op/Flag assignments to each synonym

   loop
      Bad := False;
      Next_Line;
      exit when Match (Line, "   -- Node Access Functions");

      if Match (Line, Node_Search)
        and then not Match (Node, Break_Punc)
      then
         Fields_Used := Nul;

      elsif Node = "" then
         null;

      elsif Line = "" then
         Node := Nul;

      elsif Match (Line, Plus_Binary) then
         Bad := Match (Fields_Used, B_Fields);

      elsif Match (Line, Plus_Unary) then
         Bad := Match (Fields_Used, U_Fields);

      elsif Match (Line, Plus_Expr) then
         Bad := Match (Fields_Used, E_Fields);

      elsif not Match (Line, Break_Syn) then
         null;

      elsif Match (Synonym, "plus") then
         null;

      else
         Match (Field, Break_Field);

         if not Present (Special, Synonym) then
            if Present (Fields, Synonym) then
               if Field /= Get (Fields, Synonym) then
                  Put_Line
                    ("Inconsistent field reference at line" &
                     Lineno'Img & " for " & Synonym);
                  raise Done;
               end if;

            else
               Set (Fields, Synonym, Field);
            end if;

            Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
            Match (Field, Get_Field);

            if Match (Field, "Flag") then
               Which_Field := Get (Flags, Which_Field);
            end if;

            if Match (Fields_Used, Break_WFld) then
               Put_Line
                 ("Overlapping field at line " & Lineno'Img &
                  " for " & Synonym);
               raise Done;
            end if;

            Append (Fields_Used, Which_Field);
            Bad := Bad or Match (Fields_Used, N_Fields);
         end if;
      end if;

      if Bad then
         Put_Line ("fields conflict with standard fields for node " & Node);
         raise Done;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for function consistency");

   --  Loop through field function definitions to make sure they are OK

   Fields1 := Fields;
   loop
      Next_Line;
      exit when Match (Line, "   -- Node Update");

      if Match (Line, Get_Funcsyn)
        and then not Present (Special, Synonym)
      then
         if not Present (Fields1, Synonym) then
            Put_Line
              ("function on line " &  Lineno &
               " is for unused synonym");
            raise Done;
         end if;

         Next_Line;

         if not Match (Line, Extr_Field) then
            raise Err;
         end if;

         if Field /= Get (Fields1, Synonym) then
            Put_Line ("Wrong field in function " & Synonym);
            raise Done;

         else
            Delete (Fields1, Synonym);
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing functions");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);

   begin
      if List'Length > 0 then
         Put_Line ("No function for field synonym " & List (1).Name);
         raise Done;
      end if;
   end;

   --  Check field set procedures

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for set procedure consistency");

   Fields1 := Fields;
   loop
      Next_Line;
      exit when Match (Line, "   -- Inline Pragmas");
      exit when Match (Line, "   -- Iterator Procedures");

      if Match (Line, Get_Procsyn)
        and then not Present (Special, Synonym)
      then
         if not Present (Fields1, Synonym) then
            Put_Line
              ("procedure on line " & Lineno & " is for unused synonym");
            raise Done;
         end if;

         Next_Line;

         if not Match (Line, Extr_Field) then
            raise Err;
         end if;

         if Field /= Get (Fields1, Synonym) then
            Put_Line ("Wrong field in procedure Set_" & Synonym);
            raise Done;

         else
            Delete (Fields1, Synonym);
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing set procedures");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);

   begin
      if List'Length > 0 then
         Put_Line ("No procedure for field synonym Set_" & List (1).Name);
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check pragma Inlines are all for existing subprograms");

   Clear (Fields1);
   while not End_Of_File (Infil) loop
      Next_Line;

      if Match (Line, Get_Inline)
        and then not Present (Special, Name)
      then
         exit when Match (Name, Set_Name);

         if not Present (Fields, Name) then
            Put_Line
              ("Pragma Inline on line " & Lineno &
               " does not correspond to synonym");
            raise Done;

         else
            Set (Inlines, Name, Get (Inlines, Name) & 'r');
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check no pragma Inlines were omitted");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields);
      Nxt  : VString := Nul;

   begin
      for M in List'Range loop
         Nxt := List (M).Name;

         if Get (Inlines, Nxt) /= "r" then
            Put_Line ("Incorrect pragma Inlines for " & Nxt);
            raise Done;
         end if;
      end loop;
   end;

   Put_Line ("     OK");
   New_Line;
   Clear (Inlines);

   Close (Infil);
   Open (Infil, In_File, "sinfo.adb");
   Lineno := 0;
   Put_Line ("Check references in functions in body");

   Refscopy := Refs;
   loop
      Next_Line;
      exit when Match (Line, "   -- Field Access Functions --");
   end loop;

   loop
      Next_Line;
      exit when Match (Line, "   -- Field Set Procedures --");

      if Match (Line, Func_Rest)
        and then not Present (Special, Synonym)
      then
         Ref := Get (Refs, Synonym);
         Delete (Refs, Synonym);

         if Ref = "" then
            Put_Line
              ("Function on line " & Lineno & " is for unknown synonym");
            raise Err;
         end if;

         --  Alpha sort of references for this entry

         declare
            Refa   : VStringA (1 .. 100);
            N      : Natural := 0;

         begin
            loop
               exit when not Match (Ref, Get_Nxtref, Nul);
               N := N + 1;
               Refa (N) := Nxtref;
            end loop;

            Sort (Refa (1 .. N));
            Next_Line;
            Next_Line;
            Next_Line;

            --  Checking references for one entry

            for M in 1 .. N loop
               Next_Line;

               if not Match (Line, Test_Syn) then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Done;
               end if;

               Match (Next, Chop_Comma);

               if Next /= Refa (M) then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Done;
               end if;
            end loop;

            Next_Line;
            Match (Line, Return_Fld);

            if Field /= Get (Fields, Synonym) then
               Put_Line
                ("Wrong field for function " & Synonym & " at line " &
                 Lineno & " should be " & Get (Fields, Synonym));
               raise Done;
            end if;
         end;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing functions in body");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Refs);

   begin
      if List'Length /= 0 then
         Put_Line ("Missing function " & List (1).Name & " in body");
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check Set procedures in body");
   Refs := Refscopy;

   loop
      Next_Line;
      exit when Match (Line, "end");
      exit when Match (Line, "   -- Iterator Procedures");

      if Match (Line, Set_Syn)
        and then not Present (Special, Synonym)
      then
         Ref := Get (Refs, Synonym);
         Delete (Refs, Synonym);

         if Ref = "" then
            Put_Line
              ("Function on line " & Lineno & " is for unknown synonym");
            raise Err;
         end if;

         --  Alpha sort of references for this entry

         declare
            Refa   : VStringA (1 .. 100);
            N      : Natural;

         begin
            N := 0;

            loop
               exit when not Match (Ref, Get_Nxtref, Nul);
               N := N + 1;
               Refa (N) := Nxtref;
            end loop;

            Sort (Refa (1 .. N));

            Next_Line;
            Next_Line;
            Next_Line;

            --  Checking references for one entry

            for M in 1 .. N loop
               Next_Line;

               if not Match (Line, Test_Syn)
                 or else Next /= Refa (M)
               then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Err;
               end if;
            end loop;

            loop
               Next_Line;
               exit when Match (Line, Set_Fld);
            end loop;

            Match (Field, Break_With);

            if Field /= Get (Fields, Synonym) then
               Put_Line
                 ("Wrong field for procedure Set_" & Synonym &
                  " at line " & Lineno & " should be " &
                  Get (Fields, Synonym));
               raise Done;
            end if;

            Delete (Fields1, Synonym);
         end;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing set procedures in body");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);
   begin
      if List'Length /= 0 then
         Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("All tests completed successfully, no errors detected");

end CSinfo;