1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 -- Program to check consistency of sinfo.ads and sinfo.adb. Checks that
29 -- field name usage is consistent and that assertion cross-reference lists
30 -- are correct, as well as making sure that all the comments on field name
31 -- usage are consistent.
33 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
34 with Ada
.Strings
.Unbounded
.Text_IO
; use Ada
.Strings
.Unbounded
.Text_IO
;
35 with Ada
.Strings
.Maps
; use Ada
.Strings
.Maps
;
36 with Ada
.Strings
.Maps
.Constants
; use Ada
.Strings
.Maps
.Constants
;
37 with Ada
.Text_IO
; use Ada
.Text_IO
;
39 with GNAT
.Spitbol
; use GNAT
.Spitbol
;
40 with GNAT
.Spitbol
.Patterns
; use GNAT
.Spitbol
.Patterns
;
41 with GNAT
.Spitbol
.Table_Boolean
;
42 with GNAT
.Spitbol
.Table_VString
;
46 package TB
renames GNAT
.Spitbol
.Table_Boolean
;
47 package TV
renames GNAT
.Spitbol
.Table_VString
;
51 Lineno
: Natural := 0;
54 -- Raised on fatal error
57 -- Raised after error is found to terminate run
59 WSP
: Pattern
:= Span
(' ' & ASCII
.HT
);
61 Fields
: TV
.Table
(300);
62 Fields1
: TV
.Table
(300);
63 Refs
: TV
.Table
(300);
64 Refscopy
: TV
.Table
(300);
65 Special
: TB
.Table
(50);
66 Inlines
: TV
.Table
(100);
68 -- The following define the standard fields used for binary operator,
69 -- unary operator, and other expression nodes. Numbers in the range 1-5
70 -- refer to the Fieldn fields. Letters D-R refer to flags:
88 Flags
: TV
.Table
(20);
89 -- Maps flag numbers to letters
91 N_Fields
: Pattern
:= BreakX
("JL");
92 E_Fields
: Pattern
:= BreakX
("5EFGHIJLOP");
93 U_Fields
: Pattern
:= BreakX
("1345EFGHIJKLOPQ");
94 B_Fields
: Pattern
:= BreakX
("12345EFGHIJKLOPQ");
99 Field
: VString
:= Nul
;
100 Fields_Used
: VString
:= Nul
;
101 Name
: VString
:= Nul
;
102 Next
: VString
:= Nul
;
103 Node
: VString
:= Nul
;
104 Ref
: VString
:= Nul
;
105 Synonym
: VString
:= Nul
;
106 Nxtref
: VString
:= Nul
;
108 Which_Field
: aliased VString
:= Nul
;
110 Node_Search
: Pattern
:= WSP
& "-- N_" & Rest
* Node
;
111 Break_Punc
: Pattern
:= Break
(" .,");
112 Plus_Binary
: Pattern
:= WSP
& "-- plus fields for binary operator";
113 Plus_Unary
: Pattern
:= WSP
& "-- plus fields for unary operator";
114 Plus_Expr
: Pattern
:= WSP
& "-- plus fields for expression";
115 Break_Syn
: Pattern
:= WSP
& "-- " & Break
(' ') * Synonym
&
116 " (" & Break
(')') * Field
;
117 Break_Field
: Pattern
:= BreakX
('-') * Field
;
118 Get_Field
: Pattern
:= BreakX
(Decimal_Digit_Set
) &
119 Span
(Decimal_Digit_Set
) * Which_Field
;
120 Break_WFld
: Pattern
:= Break
(Which_Field
'Access);
121 Get_Funcsyn
: Pattern
:= WSP
& "function " & Rest
* Synonym
;
122 Extr_Field
: Pattern
:= BreakX
('-') & "-- " & Rest
* Field
;
123 Get_Procsyn
: Pattern
:= WSP
& "procedure Set_" & Rest
* Synonym
;
124 Get_Inline
: Pattern
:= WSP
& "pragma Inline (" & Break
(')') * Name
;
125 Set_Name
: Pattern
:= "Set_" & Rest
* Name
;
126 Func_Rest
: Pattern
:= " function " & Rest
* Synonym
;
127 Get_Nxtref
: Pattern
:= Break
(',') * Nxtref
& ',';
128 Test_Syn
: Pattern
:= Break
('=') & "= N_" &
129 (Break
(" ,)") or Rest
) * Next
;
130 Chop_Comma
: Pattern
:= BreakX
(',') * Next
;
131 Return_Fld
: Pattern
:= WSP
& "return " & Break
(' ') * Field
;
132 Set_Syn
: Pattern
:= " procedure Set_" & Rest
* Synonym
;
133 Set_Fld
: Pattern
:= WSP
& "Set_" & Break
(' ') * Field
& " (N, Val)";
134 Break_With
: Pattern
:= Break
('_') ** Field
& "_With_Parent";
136 type VStringA
is array (Natural range <>) of VString
;
139 -- Read next line trimmed from Infil into Line and bump Lineno
141 procedure Sort
(A
: in out VStringA
);
142 -- Sort a (small) array of VString's
144 procedure Next_Line
is
146 Line
:= Get_Line
(Infil
);
148 Lineno
:= Lineno
+ 1;
151 procedure Sort
(A
: in out VStringA
) is
156 for J
in 1 .. A
'Length - 1 loop
157 if A
(J
) > A
(J
+ 1) then
166 -- Start of processing for CSinfo
169 Anchored_Mode
:= True;
171 Open
(Infil
, In_File
, "sinfo.ads");
172 Put_Line
("Check for field name consistency");
174 -- Setup table for mapping flag numbers to letters
176 Set
(Flags
, "4", V
("D"));
177 Set
(Flags
, "5", V
("E"));
178 Set
(Flags
, "6", V
("F"));
179 Set
(Flags
, "7", V
("G"));
180 Set
(Flags
, "8", V
("H"));
181 Set
(Flags
, "9", V
("I"));
182 Set
(Flags
, "10", V
("J"));
183 Set
(Flags
, "11", V
("K"));
184 Set
(Flags
, "12", V
("L"));
185 Set
(Flags
, "13", V
("M"));
186 Set
(Flags
, "14", V
("N"));
187 Set
(Flags
, "15", V
("O"));
188 Set
(Flags
, "16", V
("P"));
189 Set
(Flags
, "17", V
("Q"));
190 Set
(Flags
, "18", V
("R"));
192 -- Special fields table. The following fields are not recorded or checked
193 -- by Csinfo, since they are specially handled. This means that he both
194 -- the field definitions, and the corresponding subprograms are ignored.
196 Set
(Special
, "Analyzed", True);
197 Set
(Special
, "Assignment_OK", True);
198 Set
(Special
, "Associated_Node", True);
199 Set
(Special
, "Cannot_Be_Constant", True);
200 Set
(Special
, "Chars", True);
201 Set
(Special
, "Comes_From_Source", True);
202 Set
(Special
, "Do_Overflow_Check", True);
203 Set
(Special
, "Do_Range_Check", True);
204 Set
(Special
, "Entity", True);
205 Set
(Special
, "Error_Posted", True);
206 Set
(Special
, "Etype", True);
207 Set
(Special
, "Evaluate_Once", True);
208 Set
(Special
, "First_Itype", True);
209 Set
(Special
, "Has_Dynamic_Itype", True);
210 Set
(Special
, "Has_Dynamic_Range_Check", True);
211 Set
(Special
, "Has_Dynamic_Length_Check", True);
212 Set
(Special
, "Has_Private_View", True);
213 Set
(Special
, "Is_Controlling_Actual", True);
214 Set
(Special
, "Is_Overloaded", True);
215 Set
(Special
, "Is_Static_Expression", True);
216 Set
(Special
, "Left_Opnd", True);
217 Set
(Special
, "Must_Not_Freeze", True);
218 Set
(Special
, "Parens", True);
219 Set
(Special
, "Raises_Constraint_Error", True);
220 Set
(Special
, "Right_Opnd", True);
222 -- Loop to acquire information from node definitions in sinfo.ads,
223 -- checking for consistency in Op/Flag assignments to each synonym
228 exit when Match
(Line
, " -- Node Access Functions");
230 if Match
(Line
, Node_Search
)
231 and then not Match
(Node
, Break_Punc
)
241 elsif Match
(Line
, Plus_Binary
) then
242 Bad
:= Match
(Fields_Used
, B_Fields
);
244 elsif Match
(Line
, Plus_Unary
) then
245 Bad
:= Match
(Fields_Used
, U_Fields
);
247 elsif Match
(Line
, Plus_Expr
) then
248 Bad
:= Match
(Fields_Used
, E_Fields
);
250 elsif not Match
(Line
, Break_Syn
) then
253 elsif Match
(Synonym
, "plus") then
257 Match
(Field
, Break_Field
);
259 if not Present
(Special
, Synonym
) then
261 if Present
(Fields
, Synonym
) then
262 if Field
/= Get
(Fields
, Synonym
) then
264 ("Inconsistent field reference at line" &
265 Lineno
'Img & " for " & Synonym
);
270 Set
(Fields
, Synonym
, Field
);
273 Set
(Refs
, Synonym
, Node
& ',' & Get
(Refs
, Synonym
));
274 Match
(Field
, Get_Field
);
276 if Match
(Field
, "Flag") then
277 Which_Field
:= Get
(Flags
, Which_Field
);
280 if Match
(Fields_Used
, Break_WFld
) then
282 ("Overlapping field at line " & Lineno
'Img &
287 Append
(Fields_Used
, Which_Field
);
288 Bad
:= Bad
or Match
(Fields_Used
, N_Fields
);
293 Put_Line
("fields conflict with standard fields for node " & Node
);
299 Put_Line
("Check for function consistency");
301 -- Loop through field function definitions to make sure they are OK
306 exit when Match
(Line
, " -- Node Update");
308 if Match
(Line
, Get_Funcsyn
)
309 and then not Present
(Special
, Synonym
)
311 if not Present
(Fields1
, Synonym
) then
313 ("function on line " & Lineno
&
314 " is for unused synonym");
320 if not Match
(Line
, Extr_Field
) then
324 if Field
/= Get
(Fields1
, Synonym
) then
325 Put_Line
("Wrong field in function " & Synonym
);
329 Delete
(Fields1
, Synonym
);
336 Put_Line
("Check for missing functions");
339 List
: TV
.Table_Array
:= Convert_To_Array
(Fields1
);
342 if List
'Length > 0 then
343 Put_Line
("No function for field synonym " & List
(1).Name
);
348 -- Check field set procedures
352 Put_Line
("Check for set procedure consistency");
357 exit when Match
(Line
, " -- Inline Pragmas");
358 exit when Match
(Line
, " -- Iterator Procedures");
360 if Match
(Line
, Get_Procsyn
)
361 and then not Present
(Special
, Synonym
)
363 if not Present
(Fields1
, Synonym
) then
365 ("procedure on line " & Lineno
& " is for unused synonym");
371 if not Match
(Line
, Extr_Field
) then
375 if Field
/= Get
(Fields1
, Synonym
) then
376 Put_Line
("Wrong field in procedure Set_" & Synonym
);
380 Delete
(Fields1
, Synonym
);
387 Put_Line
("Check for missing set procedures");
390 List
: TV
.Table_Array
:= Convert_To_Array
(Fields1
);
393 if List
'Length > 0 then
394 Put_Line
("No procedure for field synonym Set_" & List
(1).Name
);
401 Put_Line
("Check pragma Inlines are all for existing subprograms");
404 while not End_Of_File
(Infil
) loop
407 if Match
(Line
, Get_Inline
)
408 and then not Present
(Special
, Name
)
410 exit when Match
(Name
, Set_Name
);
412 if not Present
(Fields
, Name
) then
414 ("Pragma Inline on line " & Lineno
&
415 " does not correspond to synonym");
419 Set
(Inlines
, Name
, Get
(Inlines
, Name
) & 'r');
426 Put_Line
("Check no pragma Inlines were omitted");
429 List
: TV
.Table_Array
:= Convert_To_Array
(Fields
);
430 Nxt
: VString
:= Nul
;
433 for M
in List
'Range loop
434 Nxt
:= List
(M
).Name
;
436 if Get
(Inlines
, Nxt
) /= "r" then
437 Put_Line
("Incorrect pragma Inlines for " & Nxt
);
448 Open
(Infil
, In_File
, "sinfo.adb");
450 Put_Line
("Check references in functions in body");
455 exit when Match
(Line
, " -- Field Access Functions --");
460 exit when Match
(Line
, " -- Field Set Procedures --");
462 if Match
(Line
, Func_Rest
)
463 and then not Present
(Special
, Synonym
)
465 Ref
:= Get
(Refs
, Synonym
);
466 Delete
(Refs
, Synonym
);
470 ("Function on line " & Lineno
& " is for unknown synonym");
474 -- Alpha sort of references for this entry
477 Refa
: VStringA
(1 .. 100);
482 exit when not Match
(Ref
, Get_Nxtref
, Nul
);
487 Sort
(Refa
(1 .. N
));
492 -- Checking references for one entry
497 if not Match
(Line
, Test_Syn
) then
498 Put_Line
("Expecting N_" & Refa
(M
) & " at line " & Lineno
);
502 Match
(Next
, Chop_Comma
);
504 if Next
/= Refa
(M
) then
505 Put_Line
("Expecting N_" & Refa
(M
) & " at line " & Lineno
);
511 Match
(Line
, Return_Fld
);
513 if Field
/= Get
(Fields
, Synonym
) then
515 ("Wrong field for function " & Synonym
& " at line " &
516 Lineno
& " should be " & Get
(Fields
, Synonym
));
525 Put_Line
("Check for missing functions in body");
528 List
: TV
.Table_Array
:= Convert_To_Array
(Refs
);
531 if List
'Length /= 0 then
532 Put_Line
("Missing function " & List
(1).Name
& " in body");
539 Put_Line
("Check Set procedures in body");
544 exit when Match
(Line
, "end");
545 exit when Match
(Line
, " -- Iterator Procedures");
547 if Match
(Line
, Set_Syn
)
548 and then not Present
(Special
, Synonym
)
550 Ref
:= Get
(Refs
, Synonym
);
551 Delete
(Refs
, Synonym
);
555 ("Function on line " & Lineno
& " is for unknown synonym");
559 -- Alpha sort of references for this entry
562 Refa
: VStringA
(1 .. 100);
569 exit when not Match
(Ref
, Get_Nxtref
, Nul
);
574 Sort
(Refa
(1 .. N
));
580 -- Checking references for one entry
585 if not Match
(Line
, Test_Syn
)
586 or else Next
/= Refa
(M
)
588 Put_Line
("Expecting N_" & Refa
(M
) & " at line " & Lineno
);
595 exit when Match
(Line
, Set_Fld
);
598 Match
(Field
, Break_With
);
600 if Field
/= Get
(Fields
, Synonym
) then
602 ("Wrong field for procedure Set_" & Synonym
&
603 " at line " & Lineno
& " should be " &
604 Get
(Fields
, Synonym
));
608 Delete
(Fields1
, Synonym
);
615 Put_Line
("Check for missing set procedures in body");
618 List
: TV
.Table_Array
:= Convert_To_Array
(Fields1
);
621 if List
'Length /= 0 then
622 Put_Line
("Missing procedure Set_" & List
(1).Name
& " in body");
629 Put_Line
("All tests completed successfully, no errors detected");