|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT SYSTEM UTILITIES --
|
|
|
4 -- --
|
|
|
5 -- C E I N F O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
|
|
111
|
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;
|
