1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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.
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.
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;
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;
47 package TB renames GNAT.Spitbol.Table_Boolean;
48 package TV renames GNAT.Spitbol.Table_VString;
52 Lineno : Natural := 0;
55 -- Raised on fatal error
58 -- Raised after error is found to terminate run
60 WSP : constant Pattern := Span (' ' & ASCII.HT);
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);
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:
89 Flags : TV.Table (20);
90 -- Maps flag numbers to letters
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");
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;
109 Which_Field : aliased VString := Nul;
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
141 Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent";
143 type VStringA is array (Natural range <>) of VString;
146 -- Read next line trimmed from Infil into Line and bump Lineno
148 procedure Sort (A : in out VStringA);
149 -- Sort a (small) array of VString's
151 procedure Next_Line is
153 Line := Get_Line (Infil);
155 Lineno := Lineno + 1;
158 procedure Sort (A : in out VStringA) is
162 for J in 1 .. A'Length - 1 loop
163 if A (J) > A (J + 1) then
172 -- Start of processing for CSinfo
175 Anchored_Mode := True;
177 Open (Infil, In_File, "sinfo.ads");
178 Put_Line ("Check for field name consistency");
180 -- Setup table for mapping flag numbers to letters
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"));
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.
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, "Implicit_With_From_Instantiation", True);
222 Set (Special, "Is_Controlling_Actual", True);
223 Set (Special, "Is_Overloaded", True);
224 Set (Special, "Is_Static_Expression", True);
225 Set (Special, "Left_Opnd", True);
226 Set (Special, "Must_Not_Freeze", True);
227 Set (Special, "Nkind_In", True);
228 Set (Special, "Parens", True);
229 Set (Special, "Pragma_Name", True);
230 Set (Special, "Raises_Constraint_Error", True);
231 Set (Special, "Right_Opnd", True);
233 -- Loop to acquire information from node definitions in sinfo.ads,
234 -- checking for consistency in Op/Flag assignments to each synonym
239 exit when Match (Line, " -- Node Access Functions");
241 if Match (Line, Node_Search)
242 and then not Match (Node, Break_Punc)
252 elsif Match (Line, Plus_Binary) then
253 Bad := Match (Fields_Used, B_Fields);
255 elsif Match (Line, Plus_Unary) then
256 Bad := Match (Fields_Used, U_Fields);
258 elsif Match (Line, Plus_Expr) then
259 Bad := Match (Fields_Used, E_Fields);
261 elsif not Match (Line, Break_Syn) then
264 elsif Match (Synonym, "plus") then
268 Match (Field, Break_Field);
270 if not Present (Special, Synonym) then
271 if Present (Fields, Synonym) then
272 if Field /= Get (Fields, Synonym) then
274 ("Inconsistent field reference at line" &
275 Lineno'Img & " for " & Synonym);
280 Set (Fields, Synonym, Field);
283 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
284 Match (Field, Get_Field);
286 if Match (Field, "Flag") then
287 Which_Field := Get (Flags, Which_Field);
290 if Match (Fields_Used, Break_WFld) then
292 ("Overlapping field at line " & Lineno'Img &
297 Append (Fields_Used, Which_Field);
298 Bad := Bad or Match (Fields_Used, N_Fields);
303 Put_Line ("fields conflict with standard fields for node " & Node);
310 Put_Line ("Check for function consistency");
312 -- Loop through field function definitions to make sure they are OK
317 exit when Match (Line, " -- Node Update");
319 if Match (Line, Get_Funcsyn)
320 and then not Present (Special, Synonym)
322 if not Present (Fields1, Synonym) then
324 ("function on line " & Lineno &
325 " is for unused synonym");
331 if not Match (Line, Extr_Field) then
335 if Field /= Get (Fields1, Synonym) then
336 Put_Line ("Wrong field in function " & Synonym);
340 Delete (Fields1, Synonym);
347 Put_Line ("Check for missing functions");
350 List : constant TV.Table_Array := Convert_To_Array (Fields1);
353 if List'Length > 0 then
354 Put_Line ("No function for field synonym " & List (1).Name);
359 -- Check field set procedures
363 Put_Line ("Check for set procedure consistency");
368 exit when Match (Line, " -- Inline Pragmas");
369 exit when Match (Line, " -- Iterator Procedures");
371 if Match (Line, Get_Procsyn)
372 and then not Present (Special, Synonym)
374 if not Present (Fields1, Synonym) then
376 ("procedure on line " & Lineno & " is for unused synonym");
382 if not Match (Line, Extr_Field) then
386 if Field /= Get (Fields1, Synonym) then
387 Put_Line ("Wrong field in procedure Set_" & Synonym);
391 Delete (Fields1, Synonym);
398 Put_Line ("Check for missing set procedures");
401 List : constant TV.Table_Array := Convert_To_Array (Fields1);
404 if List'Length > 0 then
405 Put_Line ("No procedure for field synonym Set_" & List (1).Name);
412 Put_Line ("Check pragma Inlines are all for existing subprograms");
415 while not End_Of_File (Infil) loop
418 if Match (Line, Get_Inline)
419 and then not Present (Special, Name)
421 exit when Match (Name, Set_Name);
423 if not Present (Fields, Name) then
425 ("Pragma Inline on line " & Lineno &
426 " does not correspond to synonym");
430 Set (Inlines, Name, Get (Inlines, Name) & 'r');
437 Put_Line ("Check no pragma Inlines were omitted");
440 List : constant TV.Table_Array := Convert_To_Array (Fields);
441 Nxt : VString := Nul;
444 for M in List'Range loop
445 Nxt := List (M).Name;
447 if Get (Inlines, Nxt) /= "r" then
448 Put_Line ("Incorrect pragma Inlines for " & Nxt);
459 Open (Infil, In_File, "sinfo.adb");
461 Put_Line ("Check references in functions in body");
466 exit when Match (Line, " -- Field Access Functions --");
471 exit when Match (Line, " -- Field Set Procedures --");
473 if Match (Line, Func_Rest)
474 and then not Present (Special, Synonym)
476 Ref := Get (Refs, Synonym);
477 Delete (Refs, Synonym);
481 ("Function on line " & Lineno & " is for unknown synonym");
485 -- Alpha sort of references for this entry
488 Refa : VStringA (1 .. 100);
493 exit when not Match (Ref, Get_Nxtref, Nul);
498 Sort (Refa (1 .. N));
503 -- Checking references for one entry
508 if not Match (Line, Test_Syn) then
509 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
513 Match (Next, Chop_Comma);
515 if Next /= Refa (M) then
516 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
522 Match (Line, Return_Fld);
524 if Field /= Get (Fields, Synonym) then
526 ("Wrong field for function " & Synonym & " at line " &
527 Lineno & " should be " & Get (Fields, Synonym));
536 Put_Line ("Check for missing functions in body");
539 List : constant TV.Table_Array := Convert_To_Array (Refs);
542 if List'Length /= 0 then
543 Put_Line ("Missing function " & List (1).Name & " in body");
550 Put_Line ("Check Set procedures in body");
555 exit when Match (Line, "end");
556 exit when Match (Line, " -- Iterator Procedures");
558 if Match (Line, Set_Syn)
559 and then not Present (Special, Synonym)
561 Ref := Get (Refs, Synonym);
562 Delete (Refs, Synonym);
566 ("Function on line " & Lineno & " is for unknown synonym");
570 -- Alpha sort of references for this entry
573 Refa : VStringA (1 .. 100);
580 exit when not Match (Ref, Get_Nxtref, Nul);
585 Sort (Refa (1 .. N));
591 -- Checking references for one entry
596 if not Match (Line, Test_Syn)
597 or else Next /= Refa (M)
599 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
606 exit when Match (Line, Set_Fld);
609 Match (Field, Break_With);
611 if Field /= Get (Fields, Synonym) then
613 ("Wrong field for procedure Set_" & Synonym &
614 " at line " & Lineno & " should be " &
615 Get (Fields, Synonym));
619 Delete (Fields1, Synonym);
626 Put_Line ("Check for missing set procedures in body");
629 List : constant TV.Table_Array := Convert_To_Array (Fields1);
631 if List'Length /= 0 then
632 Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
639 Put_Line ("All tests completed successfully, no errors detected");