File : ceinfo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- C E I N F O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 -- Check consistency of einfo.ads and einfo.adb. Checks that field name usage
27 -- is consistent, including comments mentioning fields.
28
29 -- Note that this is used both as a standalone program, and as a procedure
30 -- called by XEinfo. This raises an unhandled exception if it finds any
31 -- errors; we don't attempt any sophisticated error recovery.
32
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.Text_IO; use Ada.Text_IO;
36
37 with GNAT.Spitbol; use GNAT.Spitbol;
38 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
39 with GNAT.Spitbol.Table_VString;
40
41 procedure CEinfo is
42
43 package TV renames GNAT.Spitbol.Table_VString;
44 use TV;
45
46 Infil : File_Type;
47 Lineno : Natural := 0;
48
49 Err : exception;
50 -- Raised on error
51
52 Fieldnm : VString;
53 Accessfunc : VString;
54 Line : VString;
55
56 Fields : GNAT.Spitbol.Table_VString.Table (500);
57 -- Maps field names to underlying field access name
58
59 UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
60
61 Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm;
62
63 Field_Def : constant Pattern :=
64 "-- " & Fnam & " (" & Break (')') * Accessfunc;
65
66 Field_Ref : constant Pattern :=
67 " -- " & Fnam & Break ('(') & Len (1) &
68 Break (')') * Accessfunc;
69
70 Field_Com : constant Pattern := " -- " & Fnam & Span (' ') &
71 (Break (' ') or Rest) * Accessfunc;
72
73 Func_Hedr : constant Pattern := " function " & Fnam;
74
75 Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc;
76
77 Proc_Hedr : constant Pattern := " procedure " & Fnam;
78
79 Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc;
80
81 procedure Next_Line;
82 -- Read next line trimmed from Infil into Line and bump Lineno
83
84 procedure Next_Line is
85 begin
86 Line := Get_Line (Infil);
87 Trim (Line);
88 Lineno := Lineno + 1;
89 end Next_Line;
90
91 -- Start of processing for CEinfo
92
93 begin
94 Anchored_Mode := True;
95 New_Line;
96 Open (Infil, In_File, "einfo.ads");
97
98 Put_Line ("Acquiring field names from spec");
99
100 loop
101 Next_Line;
102
103 -- Old format of einfo.ads
104
105 exit when Match (Line, " -- Access Kinds --");
106
107 -- New format of einfo.ads
108
109 exit when Match (Line, "-- Access Kinds --");
110
111 if Match (Line, Field_Def) then
112 Set (Fields, Fieldnm, Accessfunc);
113 end if;
114 end loop;
115
116 Put_Line ("Checking consistent references in spec");
117
118 loop
119 Next_Line;
120 exit when Match (Line, " -- Description of Defined");
121 end loop;
122
123 loop
124 Next_Line;
125 exit when Match (Line, " -- Component_Alignment Control");
126
127 if Match (Line, Field_Ref) then
128 if Accessfunc /= "synth"
129 and then
130 Accessfunc /= "special"
131 and then
132 Accessfunc /= Get (Fields, Fieldnm)
133 then
134 if Present (Fields, Fieldnm) then
135 Put_Line ("*** field name incorrect at line " & Lineno);
136 Put_Line (" found field " & Accessfunc);
137 Put_Line (" expecting field " & Get (Fields, Fieldnm));
138
139 else
140 Put_Line
141 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
142 end if;
143
144 raise Err;
145 end if;
146 end if;
147 end loop;
148
149 Close (Infil);
150 Open (Infil, In_File, "einfo.adb");
151 Lineno := 0;
152
153 Put_Line ("Check listing of fields in body");
154
155 loop
156 Next_Line;
157 exit when Match (Line, " -- Attribute Access Functions --");
158
159 if Match (Line, Field_Com)
160 and then Fieldnm /= "(unused)"
161 and then Accessfunc /= Get (Fields, Fieldnm)
162 then
163 if Present (Fields, Fieldnm) then
164 Put_Line ("*** field name incorrect at line " & Lineno);
165 Put_Line (" found field " & Accessfunc);
166 Put_Line (" expecting field " & Get (Fields, Fieldnm));
167
168 else
169 Put_Line
170 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
171 end if;
172
173 raise Err;
174 end if;
175 end loop;
176
177 Put_Line ("Check references in access routines in body");
178
179 loop
180 Next_Line;
181 exit when Match (Line, " -- Classification Functions --");
182
183 if Match (Line, Func_Hedr) then
184 null;
185
186 elsif Match (Line, Func_Retn)
187 and then Accessfunc /= Get (Fields, Fieldnm)
188 and then Fieldnm /= "Mechanism"
189 then
190 Put_Line ("*** incorrect field at line " & Lineno);
191 Put_Line (" found field " & Accessfunc);
192 Put_Line (" expecting field " & Get (Fields, Fieldnm));
193 raise Err;
194 end if;
195 end loop;
196
197 Put_Line ("Check references in set routines in body");
198
199 loop
200 Next_Line;
201 exit when Match (Line, " -- Attribute Set Procedures");
202 end loop;
203
204 loop
205 Next_Line;
206 exit when Match (Line, " ------------");
207
208 if Match (Line, Proc_Hedr) then
209 null;
210
211 elsif Match (Line, Proc_Setf)
212 and then Accessfunc /= Get (Fields, Fieldnm)
213 and then Fieldnm /= "Mechanism"
214 then
215 Put_Line ("*** incorrect field at line " & Lineno);
216 Put_Line (" found field " & Accessfunc);
217 Put_Line (" expecting field " & Get (Fields, Fieldnm));
218 raise Err;
219 end if;
220 end loop;
221
222 Close (Infil);
223
224 Put_Line ("All tests completed successfully, no errors detected");
225
226 end CEinfo;