ceinfo.adb: Add utility for consistency checking of einfo.ad[bs].
[gcc.git] / gcc / ada / csinfo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- C S I N F O --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision$
10 -- --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
28
29 -- Program to check consistency of sinfo.ads and sinfo.adb. Checks that
30 -- field name usage is consistent and that assertion cross-reference lists
31 -- are correct, as well as making sure that all the comments on field name
32 -- usage are consistent.
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 : 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 : Pattern := BreakX ("JL");
93 E_Fields : Pattern := BreakX ("5EFGHIJLOP");
94 U_Fields : Pattern := BreakX ("1345EFGHIJKLOPQ");
95 B_Fields : Pattern := BreakX ("12345EFGHIJKLOPQ");
96
97 Line : VString;
98 Bad : Boolean;
99
100 Field : VString := Nul;
101 Fields_Used : VString := Nul;
102 Name : VString := Nul;
103 Next : VString := Nul;
104 Node : VString := Nul;
105 Ref : VString := Nul;
106 Synonym : VString := Nul;
107 Nxtref : VString := Nul;
108
109 Which_Field : aliased VString := Nul;
110
111 Node_Search : Pattern := WSP & "-- N_" & Rest * Node;
112 Break_Punc : Pattern := Break (" .,");
113 Plus_Binary : Pattern := WSP & "-- plus fields for binary operator";
114 Plus_Unary : Pattern := WSP & "-- plus fields for unary operator";
115 Plus_Expr : Pattern := WSP & "-- plus fields for expression";
116 Break_Syn : Pattern := WSP & "-- " & Break (' ') * Synonym &
117 " (" & Break (')') * Field;
118 Break_Field : Pattern := BreakX ('-') * Field;
119 Get_Field : Pattern := BreakX (Decimal_Digit_Set) &
120 Span (Decimal_Digit_Set) * Which_Field;
121 Break_WFld : Pattern := Break (Which_Field'Access);
122 Get_Funcsyn : Pattern := WSP & "function " & Rest * Synonym;
123 Extr_Field : Pattern := BreakX ('-') & "-- " & Rest * Field;
124 Get_Procsyn : Pattern := WSP & "procedure Set_" & Rest * Synonym;
125 Get_Inline : Pattern := WSP & "pragma Inline (" & Break (')') * Name;
126 Set_Name : Pattern := "Set_" & Rest * Name;
127 Func_Rest : Pattern := " function " & Rest * Synonym;
128 Get_Nxtref : Pattern := Break (',') * Nxtref & ',';
129 Test_Syn : Pattern := Break ('=') & "= N_" &
130 (Break (" ,)") or Rest) * Next;
131 Chop_Comma : Pattern := BreakX (',') * Next;
132 Return_Fld : Pattern := WSP & "return " & Break (' ') * Field;
133 Set_Syn : Pattern := " procedure Set_" & Rest * Synonym;
134 Set_Fld : Pattern := WSP & "Set_" & Break (' ') * Field & " (N, Val)";
135 Break_With : Pattern := Break ('_') ** Field & "_With_Parent";
136
137 type VStringA is array (Natural range <>) of VString;
138
139 procedure Next_Line;
140 -- Read next line trimmed from Infil into Line and bump Lineno
141
142 procedure Sort (A : in out VStringA);
143 -- Sort a (small) array of VString's
144
145 procedure Next_Line is
146 begin
147 Line := Get_Line (Infil);
148 Trim (Line);
149 Lineno := Lineno + 1;
150 end Next_Line;
151
152 procedure Sort (A : in out VStringA) is
153 Temp : VString;
154
155 begin
156 <<Sort>>
157 for J in 1 .. A'Length - 1 loop
158 if A (J) > A (J + 1) then
159 Temp := A (J);
160 A (J) := A (J + 1);
161 A (J + 1) := Temp;
162 goto Sort;
163 end if;
164 end loop;
165 end Sort;
166
167 -- Start of processing for CSinfo
168
169 begin
170 Anchored_Mode := True;
171 New_Line;
172 Open (Infil, In_File, "sinfo.ads");
173 Put_Line ("Check for field name consistency");
174
175 -- Setup table for mapping flag numbers to letters
176
177 Set (Flags, "4", V ("D"));
178 Set (Flags, "5", V ("E"));
179 Set (Flags, "6", V ("F"));
180 Set (Flags, "7", V ("G"));
181 Set (Flags, "8", V ("H"));
182 Set (Flags, "9", V ("I"));
183 Set (Flags, "10", V ("J"));
184 Set (Flags, "11", V ("K"));
185 Set (Flags, "12", V ("L"));
186 Set (Flags, "13", V ("M"));
187 Set (Flags, "14", V ("N"));
188 Set (Flags, "15", V ("O"));
189 Set (Flags, "16", V ("P"));
190 Set (Flags, "17", V ("Q"));
191 Set (Flags, "18", V ("R"));
192
193 -- Special fields table. The following fields are not recorded or checked
194 -- by Csinfo, since they are specially handled. This means that he both
195 -- the field definitions, and the corresponding subprograms are ignored.
196
197 Set (Special, "Analyzed", True);
198 Set (Special, "Assignment_OK", True);
199 Set (Special, "Associated_Node", True);
200 Set (Special, "Cannot_Be_Constant", True);
201 Set (Special, "Chars", True);
202 Set (Special, "Comes_From_Source", True);
203 Set (Special, "Do_Overflow_Check", True);
204 Set (Special, "Do_Range_Check", True);
205 Set (Special, "Entity", True);
206 Set (Special, "Error_Posted", True);
207 Set (Special, "Etype", True);
208 Set (Special, "Evaluate_Once", True);
209 Set (Special, "First_Itype", True);
210 Set (Special, "Has_Dynamic_Itype", True);
211 Set (Special, "Has_Dynamic_Range_Check", True);
212 Set (Special, "Has_Dynamic_Length_Check", True);
213 Set (Special, "Has_Private_View", True);
214 Set (Special, "Is_Controlling_Actual", True);
215 Set (Special, "Is_Overloaded", True);
216 Set (Special, "Is_Static_Expression", True);
217 Set (Special, "Left_Opnd", True);
218 Set (Special, "Must_Not_Freeze", True);
219 Set (Special, "Parens", True);
220 Set (Special, "Raises_Constraint_Error", True);
221 Set (Special, "Right_Opnd", True);
222
223 -- Loop to acquire information from node definitions in sinfo.ads,
224 -- checking for consistency in Op/Flag assignments to each synonym
225
226 loop
227 Bad := False;
228 Next_Line;
229 exit when Match (Line, " -- Node Access Functions");
230
231 if Match (Line, Node_Search)
232 and then not Match (Node, Break_Punc)
233 then
234 Fields_Used := Nul;
235
236 elsif Node = "" then
237 null;
238
239 elsif Line = "" then
240 Node := Nul;
241
242 elsif Match (Line, Plus_Binary) then
243 Bad := Match (Fields_Used, B_Fields);
244
245 elsif Match (Line, Plus_Unary) then
246 Bad := Match (Fields_Used, U_Fields);
247
248 elsif Match (Line, Plus_Expr) then
249 Bad := Match (Fields_Used, E_Fields);
250
251 elsif not Match (Line, Break_Syn) then
252 null;
253
254 elsif Match (Synonym, "plus") then
255 null;
256
257 else
258 Match (Field, Break_Field);
259
260 if not Present (Special, Synonym) then
261
262 if Present (Fields, Synonym) then
263 if Field /= Get (Fields, Synonym) then
264 Put_Line
265 ("Inconsistent field reference at line" &
266 Lineno'Img & " for " & Synonym);
267 raise Done;
268 end if;
269
270 else
271 Set (Fields, Synonym, Field);
272 end if;
273
274 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
275 Match (Field, Get_Field);
276
277 if Match (Field, "Flag") then
278 Which_Field := Get (Flags, Which_Field);
279 end if;
280
281 if Match (Fields_Used, Break_WFld) then
282 Put_Line
283 ("Overlapping field at line " & Lineno'Img &
284 " for " & Synonym);
285 raise Done;
286 end if;
287
288 Append (Fields_Used, Which_Field);
289 Bad := Bad or Match (Fields_Used, N_Fields);
290 end if;
291 end if;
292
293 if Bad then
294 Put_Line ("fields conflict with standard fields for node " & Node);
295 end if;
296 end loop;
297
298 Put_Line (" OK");
299 New_Line;
300 Put_Line ("Check for function consistency");
301
302 -- Loop through field function definitions to make sure they are OK
303
304 Fields1 := Fields;
305 loop
306 Next_Line;
307 exit when Match (Line, " -- Node Update");
308
309 if Match (Line, Get_Funcsyn)
310 and then not Present (Special, Synonym)
311 then
312 if not Present (Fields1, Synonym) then
313 Put_Line
314 ("function on line " & Lineno &
315 " is for unused synonym");
316 raise Done;
317 end if;
318
319 Next_Line;
320
321 if not Match (Line, Extr_Field) then
322 raise Err;
323 end if;
324
325 if Field /= Get (Fields1, Synonym) then
326 Put_Line ("Wrong field in function " & Synonym);
327 raise Done;
328
329 else
330 Delete (Fields1, Synonym);
331 end if;
332 end if;
333 end loop;
334
335 Put_Line (" OK");
336 New_Line;
337 Put_Line ("Check for missing functions");
338
339 declare
340 List : TV.Table_Array := Convert_To_Array (Fields1);
341
342 begin
343 if List'Length > 0 then
344 Put_Line ("No function for field synonym " & List (1).Name);
345 raise Done;
346 end if;
347 end;
348
349 -- Check field set procedures
350
351 Put_Line (" OK");
352 New_Line;
353 Put_Line ("Check for set procedure consistency");
354
355 Fields1 := Fields;
356 loop
357 Next_Line;
358 exit when Match (Line, " -- Inline Pragmas");
359 exit when Match (Line, " -- Iterator Procedures");
360
361 if Match (Line, Get_Procsyn)
362 and then not Present (Special, Synonym)
363 then
364 if not Present (Fields1, Synonym) then
365 Put_Line
366 ("procedure on line " & Lineno & " is for unused synonym");
367 raise Done;
368 end if;
369
370 Next_Line;
371
372 if not Match (Line, Extr_Field) then
373 raise Err;
374 end if;
375
376 if Field /= Get (Fields1, Synonym) then
377 Put_Line ("Wrong field in procedure Set_" & Synonym);
378 raise Done;
379
380 else
381 Delete (Fields1, Synonym);
382 end if;
383 end if;
384 end loop;
385
386 Put_Line (" OK");
387 New_Line;
388 Put_Line ("Check for missing set procedures");
389
390 declare
391 List : TV.Table_Array := Convert_To_Array (Fields1);
392
393 begin
394 if List'Length > 0 then
395 Put_Line ("No procedure for field synonym Set_" & List (1).Name);
396 raise Done;
397 end if;
398 end;
399
400 Put_Line (" OK");
401 New_Line;
402 Put_Line ("Check pragma Inlines are all for existing subprograms");
403
404 Clear (Fields1);
405 while not End_Of_File (Infil) loop
406 Next_Line;
407
408 if Match (Line, Get_Inline)
409 and then not Present (Special, Name)
410 then
411 exit when Match (Name, Set_Name);
412
413 if not Present (Fields, Name) then
414 Put_Line
415 ("Pragma Inline on line " & Lineno &
416 " does not correspond to synonym");
417 raise Done;
418
419 else
420 Set (Inlines, Name, Get (Inlines, Name) & 'r');
421 end if;
422 end if;
423 end loop;
424
425 Put_Line (" OK");
426 New_Line;
427 Put_Line ("Check no pragma Inlines were omitted");
428
429 declare
430 List : TV.Table_Array := Convert_To_Array (Fields);
431 Nxt : VString := Nul;
432
433 begin
434 for M in List'Range loop
435 Nxt := List (M).Name;
436
437 if Get (Inlines, Nxt) /= "r" then
438 Put_Line ("Incorrect pragma Inlines for " & Nxt);
439 raise Done;
440 end if;
441 end loop;
442 end;
443
444 Put_Line (" OK");
445 New_Line;
446 Clear (Inlines);
447
448 Close (Infil);
449 Open (Infil, In_File, "sinfo.adb");
450 Lineno := 0;
451 Put_Line ("Check references in functions in body");
452
453 Refscopy := Refs;
454 loop
455 Next_Line;
456 exit when Match (Line, " -- Field Access Functions --");
457 end loop;
458
459 loop
460 Next_Line;
461 exit when Match (Line, " -- Field Set Procedures --");
462
463 if Match (Line, Func_Rest)
464 and then not Present (Special, Synonym)
465 then
466 Ref := Get (Refs, Synonym);
467 Delete (Refs, Synonym);
468
469 if Ref = "" then
470 Put_Line
471 ("Function on line " & Lineno & " is for unknown synonym");
472 raise Err;
473 end if;
474
475 -- Alpha sort of references for this entry
476
477 declare
478 Refa : VStringA (1 .. 100);
479 N : Natural := 0;
480
481 begin
482 loop
483 exit when not Match (Ref, Get_Nxtref, Nul);
484 N := N + 1;
485 Refa (N) := Nxtref;
486 end loop;
487
488 Sort (Refa (1 .. N));
489 Next_Line;
490 Next_Line;
491 Next_Line;
492
493 -- Checking references for one entry
494
495 for M in 1 .. N loop
496 Next_Line;
497
498 if not Match (Line, Test_Syn) then
499 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
500 raise Done;
501 end if;
502
503 Match (Next, Chop_Comma);
504
505 if Next /= Refa (M) then
506 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
507 raise Done;
508 end if;
509 end loop;
510
511 Next_Line;
512 Match (Line, Return_Fld);
513
514 if Field /= Get (Fields, Synonym) then
515 Put_Line
516 ("Wrong field for function " & Synonym & " at line " &
517 Lineno & " should be " & Get (Fields, Synonym));
518 raise Done;
519 end if;
520 end;
521 end if;
522 end loop;
523
524 Put_Line (" OK");
525 New_Line;
526 Put_Line ("Check for missing functions in body");
527
528 declare
529 List : TV.Table_Array := Convert_To_Array (Refs);
530
531 begin
532 if List'Length /= 0 then
533 Put_Line ("Missing function " & List (1).Name & " in body");
534 raise Done;
535 end if;
536 end;
537
538 Put_Line (" OK");
539 New_Line;
540 Put_Line ("Check Set procedures in body");
541 Refs := Refscopy;
542
543 loop
544 Next_Line;
545 exit when Match (Line, "end");
546 exit when Match (Line, " -- Iterator Procedures");
547
548 if Match (Line, Set_Syn)
549 and then not Present (Special, Synonym)
550 then
551 Ref := Get (Refs, Synonym);
552 Delete (Refs, Synonym);
553
554 if Ref = "" then
555 Put_Line
556 ("Function on line " & Lineno & " is for unknown synonym");
557 raise Err;
558 end if;
559
560 -- Alpha sort of references for this entry
561
562 declare
563 Refa : VStringA (1 .. 100);
564 N : Natural;
565
566 begin
567 N := 0;
568
569 loop
570 exit when not Match (Ref, Get_Nxtref, Nul);
571 N := N + 1;
572 Refa (N) := Nxtref;
573 end loop;
574
575 Sort (Refa (1 .. N));
576
577 Next_Line;
578 Next_Line;
579 Next_Line;
580
581 -- Checking references for one entry
582
583 for M in 1 .. N loop
584 Next_Line;
585
586 if not Match (Line, Test_Syn)
587 or else Next /= Refa (M)
588 then
589 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
590 raise Err;
591 end if;
592 end loop;
593
594 loop
595 Next_Line;
596 exit when Match (Line, Set_Fld);
597 end loop;
598
599 Match (Field, Break_With);
600
601 if Field /= Get (Fields, Synonym) then
602 Put_Line
603 ("Wrong field for procedure Set_" & Synonym &
604 " at line " & Lineno & " should be " &
605 Get (Fields, Synonym));
606 raise Done;
607 end if;
608
609 Delete (Fields1, Synonym);
610 end;
611 end if;
612 end loop;
613
614 Put_Line (" OK");
615 New_Line;
616 Put_Line ("Check for missing set procedures in body");
617
618 declare
619 List : TV.Table_Array := Convert_To_Array (Fields1);
620
621 begin
622 if List'Length /= 0 then
623 Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
624 raise Done;
625 end if;
626 end;
627
628 Put_Line (" OK");
629 New_Line;
630 Put_Line ("All tests completed successfully, no errors detected");
631
632 exception
633 when Done =>
634 null;
635
636 end CSinfo;