1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- Program to check consistency of sinfo.ads and sinfo.adb. Checks that
28 -- field name usage is consistent and that assertion cross-reference lists
29 -- are correct, as well as making sure that all the comments on field name
30 -- usage are consistent.
32 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
33 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
34 with Ada.Strings.Maps; use Ada.Strings.Maps;
35 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
36 with Ada.Text_IO; use Ada.Text_IO;
38 with GNAT.Spitbol; use GNAT.Spitbol;
39 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
40 with GNAT.Spitbol.Table_Boolean;
41 with GNAT.Spitbol.Table_VString;
45 package TB renames GNAT.Spitbol.Table_Boolean;
46 package TV renames GNAT.Spitbol.Table_VString;
50 Lineno : Natural := 0;
53 -- Raised on fatal error
56 -- Raised after error is found to terminate run
58 WSP : Pattern := Span (' ' & ASCII.HT);
60 Fields : TV.Table (300);
61 Fields1 : TV.Table (300);
62 Refs : TV.Table (300);
63 Refscopy : TV.Table (300);
64 Special : TB.Table (50);
65 Inlines : TV.Table (100);
67 -- The following define the standard fields used for binary operator,
68 -- unary operator, and other expression nodes. Numbers in the range 1-5
69 -- refer to the Fieldn fields. Letters D-R refer to flags:
87 Flags : TV.Table (20);
88 -- Maps flag numbers to letters
90 N_Fields : Pattern := BreakX ("JL");
91 E_Fields : Pattern := BreakX ("5EFGHIJLOP");
92 U_Fields : Pattern := BreakX ("1345EFGHIJKLOPQ");
93 B_Fields : Pattern := BreakX ("12345EFGHIJKLOPQ");
98 Field : VString := Nul;
99 Fields_Used : VString := Nul;
100 Name : VString := Nul;
101 Next : VString := Nul;
102 Node : VString := Nul;
103 Ref : VString := Nul;
104 Synonym : VString := Nul;
105 Nxtref : VString := Nul;
107 Which_Field : aliased VString := Nul;
109 Node_Search : Pattern := WSP & "-- N_" & Rest * Node;
110 Break_Punc : Pattern := Break (" .,");
111 Plus_Binary : Pattern := WSP & "-- plus fields for binary operator";
112 Plus_Unary : Pattern := WSP & "-- plus fields for unary operator";
113 Plus_Expr : Pattern := WSP & "-- plus fields for expression";
114 Break_Syn : Pattern := WSP & "-- " & Break (' ') * Synonym &
115 " (" & Break (')') * Field;
116 Break_Field : Pattern := BreakX ('-') * Field;
117 Get_Field : Pattern := BreakX (Decimal_Digit_Set) &
118 Span (Decimal_Digit_Set) * Which_Field;
119 Break_WFld : Pattern := Break (Which_Field'Access);
120 Get_Funcsyn : Pattern := WSP & "function " & Rest * Synonym;
121 Extr_Field : Pattern := BreakX ('-') & "-- " & Rest * Field;
122 Get_Procsyn : Pattern := WSP & "procedure Set_" & Rest * Synonym;
123 Get_Inline : Pattern := WSP & "pragma Inline (" & Break (')') * Name;
124 Set_Name : Pattern := "Set_" & Rest * Name;
125 Func_Rest : Pattern := " function " & Rest * Synonym;
126 Get_Nxtref : Pattern := Break (',') * Nxtref & ',';
127 Test_Syn : Pattern := Break ('=') & "= N_" &
128 (Break (" ,)") or Rest) * Next;
129 Chop_Comma : Pattern := BreakX (',') * Next;
130 Return_Fld : Pattern := WSP & "return " & Break (' ') * Field;
131 Set_Syn : Pattern := " procedure Set_" & Rest * Synonym;
132 Set_Fld : Pattern := WSP & "Set_" & Break (' ') * Field & " (N, Val)";
133 Break_With : Pattern := Break ('_') ** Field & "_With_Parent";
135 type VStringA is array (Natural range <>) of VString;
138 -- Read next line trimmed from Infil into Line and bump Lineno
140 procedure Sort (A : in out VStringA);
141 -- Sort a (small) array of VString's
143 procedure Next_Line is
145 Line := Get_Line (Infil);
147 Lineno := Lineno + 1;
150 procedure Sort (A : in out VStringA) is
154 for J in 1 .. A'Length - 1 loop
155 if A (J) > A (J + 1) then
164 -- Start of processing for CSinfo
167 Anchored_Mode := True;
169 Open (Infil, In_File, "sinfo.ads");
170 Put_Line ("Check for field name consistency");
172 -- Setup table for mapping flag numbers to letters
174 Set (Flags, "4", V ("D"));
175 Set (Flags, "5", V ("E"));
176 Set (Flags, "6", V ("F"));
177 Set (Flags, "7", V ("G"));
178 Set (Flags, "8", V ("H"));
179 Set (Flags, "9", V ("I"));
180 Set (Flags, "10", V ("J"));
181 Set (Flags, "11", V ("K"));
182 Set (Flags, "12", V ("L"));
183 Set (Flags, "13", V ("M"));
184 Set (Flags, "14", V ("N"));
185 Set (Flags, "15", V ("O"));
186 Set (Flags, "16", V ("P"));
187 Set (Flags, "17", V ("Q"));
188 Set (Flags, "18", V ("R"));
190 -- Special fields table. The following fields are not recorded or checked
191 -- by Csinfo, since they are specially handled. This means that both the
192 -- field definitions, and the corresponding subprograms are ignored.
194 Set (Special, "Analyzed", True);
195 Set (Special, "Assignment_OK", True);
196 Set (Special, "Associated_Node", True);
197 Set (Special, "Cannot_Be_Constant", True);
198 Set (Special, "Chars", True);
199 Set (Special, "Comes_From_Source", True);
200 Set (Special, "Do_Overflow_Check", True);
201 Set (Special, "Do_Range_Check", True);
202 Set (Special, "Entity", True);
203 Set (Special, "Entity_Or_Associated_Node", True);
204 Set (Special, "Error_Posted", True);
205 Set (Special, "Etype", True);
206 Set (Special, "Evaluate_Once", True);
207 Set (Special, "First_Itype", True);
208 Set (Special, "Has_Dynamic_Itype", True);
209 Set (Special, "Has_Dynamic_Range_Check", True);
210 Set (Special, "Has_Dynamic_Length_Check", True);
211 Set (Special, "Has_Private_View", True);
212 Set (Special, "Is_Controlling_Actual", True);
213 Set (Special, "Is_Overloaded", True);
214 Set (Special, "Is_Static_Expression", True);
215 Set (Special, "Left_Opnd", True);
216 Set (Special, "Must_Not_Freeze", True);
217 Set (Special, "Parens", True);
218 Set (Special, "Raises_Constraint_Error", True);
219 Set (Special, "Right_Opnd", True);
221 -- Loop to acquire information from node definitions in sinfo.ads,
222 -- checking for consistency in Op/Flag assignments to each synonym
227 exit when Match (Line, " -- Node Access Functions");
229 if Match (Line, Node_Search)
230 and then not Match (Node, Break_Punc)
240 elsif Match (Line, Plus_Binary) then
241 Bad := Match (Fields_Used, B_Fields);
243 elsif Match (Line, Plus_Unary) then
244 Bad := Match (Fields_Used, U_Fields);
246 elsif Match (Line, Plus_Expr) then
247 Bad := Match (Fields_Used, E_Fields);
249 elsif not Match (Line, Break_Syn) then
252 elsif Match (Synonym, "plus") then
256 Match (Field, Break_Field);
258 if not Present (Special, Synonym) then
259 if Present (Fields, Synonym) then
260 if Field /= Get (Fields, Synonym) then
262 ("Inconsistent field reference at line" &
263 Lineno'Img & " for " & Synonym);
268 Set (Fields, Synonym, Field);
271 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
272 Match (Field, Get_Field);
274 if Match (Field, "Flag") then
275 Which_Field := Get (Flags, Which_Field);
278 if Match (Fields_Used, Break_WFld) then
280 ("Overlapping field at line " & Lineno'Img &
285 Append (Fields_Used, Which_Field);
286 Bad := Bad or Match (Fields_Used, N_Fields);
291 Put_Line ("fields conflict with standard fields for node " & Node);
297 Put_Line ("Check for function consistency");
299 -- Loop through field function definitions to make sure they are OK
304 exit when Match (Line, " -- Node Update");
306 if Match (Line, Get_Funcsyn)
307 and then not Present (Special, Synonym)
309 if not Present (Fields1, Synonym) then
311 ("function on line " & Lineno &
312 " is for unused synonym");
318 if not Match (Line, Extr_Field) then
322 if Field /= Get (Fields1, Synonym) then
323 Put_Line ("Wrong field in function " & Synonym);
327 Delete (Fields1, Synonym);
334 Put_Line ("Check for missing functions");
337 List : TV.Table_Array := Convert_To_Array (Fields1);
340 if List'Length > 0 then
341 Put_Line ("No function for field synonym " & List (1).Name);
346 -- Check field set procedures
350 Put_Line ("Check for set procedure consistency");
355 exit when Match (Line, " -- Inline Pragmas");
356 exit when Match (Line, " -- Iterator Procedures");
358 if Match (Line, Get_Procsyn)
359 and then not Present (Special, Synonym)
361 if not Present (Fields1, Synonym) then
363 ("procedure on line " & Lineno & " is for unused synonym");
369 if not Match (Line, Extr_Field) then
373 if Field /= Get (Fields1, Synonym) then
374 Put_Line ("Wrong field in procedure Set_" & Synonym);
378 Delete (Fields1, Synonym);
385 Put_Line ("Check for missing set procedures");
388 List : TV.Table_Array := Convert_To_Array (Fields1);
391 if List'Length > 0 then
392 Put_Line ("No procedure for field synonym Set_" & List (1).Name);
399 Put_Line ("Check pragma Inlines are all for existing subprograms");
402 while not End_Of_File (Infil) loop
405 if Match (Line, Get_Inline)
406 and then not Present (Special, Name)
408 exit when Match (Name, Set_Name);
410 if not Present (Fields, Name) then
412 ("Pragma Inline on line " & Lineno &
413 " does not correspond to synonym");
417 Set (Inlines, Name, Get (Inlines, Name) & 'r');
424 Put_Line ("Check no pragma Inlines were omitted");
427 List : TV.Table_Array := Convert_To_Array (Fields);
428 Nxt : VString := Nul;
431 for M in List'Range loop
432 Nxt := List (M).Name;
434 if Get (Inlines, Nxt) /= "r" then
435 Put_Line ("Incorrect pragma Inlines for " & Nxt);
446 Open (Infil, In_File, "sinfo.adb");
448 Put_Line ("Check references in functions in body");
453 exit when Match (Line, " -- Field Access Functions --");
458 exit when Match (Line, " -- Field Set Procedures --");
460 if Match (Line, Func_Rest)
461 and then not Present (Special, Synonym)
463 Ref := Get (Refs, Synonym);
464 Delete (Refs, Synonym);
468 ("Function on line " & Lineno & " is for unknown synonym");
472 -- Alpha sort of references for this entry
475 Refa : VStringA (1 .. 100);
480 exit when not Match (Ref, Get_Nxtref, Nul);
485 Sort (Refa (1 .. N));
490 -- Checking references for one entry
495 if not Match (Line, Test_Syn) then
496 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
500 Match (Next, Chop_Comma);
502 if Next /= Refa (M) then
503 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
509 Match (Line, Return_Fld);
511 if Field /= Get (Fields, Synonym) then
513 ("Wrong field for function " & Synonym & " at line " &
514 Lineno & " should be " & Get (Fields, Synonym));
523 Put_Line ("Check for missing functions in body");
526 List : TV.Table_Array := Convert_To_Array (Refs);
529 if List'Length /= 0 then
530 Put_Line ("Missing function " & List (1).Name & " in body");
537 Put_Line ("Check Set procedures in body");
542 exit when Match (Line, "end");
543 exit when Match (Line, " -- Iterator Procedures");
545 if Match (Line, Set_Syn)
546 and then not Present (Special, Synonym)
548 Ref := Get (Refs, Synonym);
549 Delete (Refs, Synonym);
553 ("Function on line " & Lineno & " is for unknown synonym");
557 -- Alpha sort of references for this entry
560 Refa : VStringA (1 .. 100);
567 exit when not Match (Ref, Get_Nxtref, Nul);
572 Sort (Refa (1 .. N));
578 -- Checking references for one entry
583 if not Match (Line, Test_Syn)
584 or else Next /= Refa (M)
586 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
593 exit when Match (Line, Set_Fld);
596 Match (Field, Break_With);
598 if Field /= Get (Fields, Synonym) then
600 ("Wrong field for procedure Set_" & Synonym &
601 " at line " & Lineno & " should be " &
602 Get (Fields, Synonym));
606 Delete (Fields1, Synonym);
613 Put_Line ("Check for missing set procedures in body");
616 List : TV.Table_Array := Convert_To_Array (Fields1);
619 if List'Length /= 0 then
620 Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
627 Put_Line ("All tests completed successfully, no errors detected");