1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1998-2007, 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 -- Program to check consistency of einfo.ads and einfo.adb. Checks that
27 -- field name usage is consistent, including comments mentioning fields.
29 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
30 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
31 with Ada.Text_IO; use Ada.Text_IO;
33 with GNAT.Spitbol; use GNAT.Spitbol;
34 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
35 with GNAT.Spitbol.Table_VString;
39 package TV renames GNAT.Spitbol.Table_VString;
43 Lineno : Natural := 0;
49 Fields : GNAT.Spitbol.Table_VString.Table (500);
50 -- Maps field names to underlying field access name
52 UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
54 Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm;
56 Field_Def : constant Pattern :=
57 "-- " & Fnam & " (" & Break (')') * Accessfunc;
59 Field_Ref : constant Pattern :=
60 " -- " & Fnam & Break ('(') & Len (1) &
61 Break (')') * Accessfunc;
63 Field_Com : constant Pattern := " -- " & Fnam & Span (' ') &
64 (Break (' ') or Rest) * Accessfunc;
66 Func_Hedr : constant Pattern := " function " & Fnam;
68 Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc;
70 Proc_Hedr : constant Pattern := " procedure " & Fnam;
72 Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc;
75 -- Read next line trimmed from Infil into Line and bump Lineno
77 procedure Next_Line is
79 Line := Get_Line (Infil);
84 -- Start of processing for CEinfo
87 Anchored_Mode := True;
89 Open (Infil, In_File, "einfo.ads");
91 Put_Line ("Acquiring field names from spec");
95 exit when Match (Line, " -- Access Kinds --");
97 if Match (Line, Field_Def) then
98 Set (Fields, Fieldnm, Accessfunc);
102 Put_Line ("Checking consistent references in spec");
106 exit when Match (Line, " -- Description of Defined");
111 exit when Match (Line, " -- Component_Alignment Control");
113 if Match (Line, Field_Ref) then
114 if Accessfunc /= "synth"
116 Accessfunc /= "special"
118 Accessfunc /= Get (Fields, Fieldnm)
120 if Present (Fields, Fieldnm) then
121 Put_Line ("*** field name incorrect at line " & Lineno);
122 Put_Line (" found field " & Accessfunc);
123 Put_Line (" expecting field " & Get (Fields, Fieldnm));
127 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
134 Open (Infil, In_File, "einfo.adb");
137 Put_Line ("Check listing of fields in body");
141 exit when Match (Line, " -- Attribute Access Functions --");
143 if Match (Line, Field_Com)
144 and then Fieldnm /= "(unused)"
145 and then Accessfunc /= Get (Fields, Fieldnm)
147 if Present (Fields, Fieldnm) then
148 Put_Line ("*** field name incorrect at line " & Lineno);
149 Put_Line (" found field " & Accessfunc);
150 Put_Line (" expecting field " & Get (Fields, Fieldnm));
154 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
159 Put_Line ("Check references in access routines in body");
163 exit when Match (Line, " -- Classification Functions --");
165 if Match (Line, Func_Hedr) then
168 elsif Match (Line, Func_Retn)
169 and then Accessfunc /= Get (Fields, Fieldnm)
170 and then Fieldnm /= "Mechanism"
172 Put_Line ("*** incorrect field at line " & Lineno);
173 Put_Line (" found field " & Accessfunc);
174 Put_Line (" expecting field " & Get (Fields, Fieldnm));
178 Put_Line ("Check references in set routines in body");
182 exit when Match (Line, " -- Attribute Set Procedures");
187 exit when Match (Line, " ------------");
189 if Match (Line, Proc_Hedr) then
192 elsif Match (Line, Proc_Setf)
193 and then Accessfunc /= Get (Fields, Fieldnm)
194 and then Fieldnm /= "Mechanism"
196 Put_Line ("*** incorrect field at line " & Lineno);
197 Put_Line (" found field " & Accessfunc);
198 Put_Line (" expecting field " & Get (Fields, Fieldnm));
202 Put_Line ("All tests completed successfully, no errors detected");