1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
10 -- Copyright (C) 1998 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 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 -- Program to check consistency of einfo.ads and einfo.adb. Checks that
29 -- field name usage is consistent, including comments mentioning fields.
31 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
32 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
33 with Ada.Text_IO; use Ada.Text_IO;
35 with GNAT.Spitbol; use GNAT.Spitbol;
36 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
37 with GNAT.Spitbol.Table_VString;
41 package TV renames GNAT.Spitbol.Table_VString;
45 Lineno : Natural := 0;
48 -- Raised on fatal error
54 Fields : GNAT.Spitbol.Table_VString.Table (500);
55 -- Maps field names to underlying field access name
57 UC : Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
59 Fnam : Pattern := (UC & Break (' ')) * Fieldnm;
61 Field_Def : Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc;
63 Field_Ref : Pattern := " -- " & Fnam & Break ('(') & Len (1) &
64 Break (')') * Accessfunc;
66 Field_Com : Pattern := " -- " & Fnam & Span (' ') &
67 (Break (' ') or Rest) * Accessfunc;
69 Func_Hedr : Pattern := " function " & Fnam;
71 Func_Retn : Pattern := " return " & Break (' ') * Accessfunc;
73 Proc_Hedr : Pattern := " procedure " & Fnam;
75 Proc_Setf : Pattern := " Set_" & Break (' ') * Accessfunc;
78 -- Read next line trimmed from Infil into Line and bump Lineno
80 procedure Next_Line is
82 Line := Get_Line (Infil);
87 -- Start of processing for CEinfo
90 Anchored_Mode := True;
92 Open (Infil, In_File, "einfo.ads");
94 Put_Line ("Acquiring field names from spec");
98 exit when Match (Line, " -- Access Kinds --");
100 if Match (Line, Field_Def) then
101 Set (Fields, Fieldnm, Accessfunc);
105 Put_Line ("Checking consistent references in spec");
109 exit when Match (Line, " -- Description of Defined");
114 exit when Match (Line, " -- Component_Alignment Control");
116 if Match (Line, Field_Ref) then
117 if Accessfunc /= "synth"
119 Accessfunc /= "special"
121 Accessfunc /= Get (Fields, Fieldnm)
123 if Present (Fields, Fieldnm) then
124 Put_Line ("*** field name incorrect at line " & Lineno);
125 Put_Line (" found field " & Accessfunc);
126 Put_Line (" expecting field " & Get (Fields, Fieldnm));
130 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
137 Open (Infil, In_File, "einfo.adb");
140 Put_Line ("Check listing of fields in body");
144 exit when Match (Line, " -- Attribute Access Functions --");
146 if Match (Line, Field_Com)
147 and then Fieldnm /= "(unused)"
148 and then Accessfunc /= Get (Fields, Fieldnm)
150 if Present (Fields, Fieldnm) then
151 Put_Line ("*** field name incorrect at line " & Lineno);
152 Put_Line (" found field " & Accessfunc);
153 Put_Line (" expecting field " & Get (Fields, Fieldnm));
157 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
162 Put_Line ("Check references in access routines in body");
166 exit when Match (Line, " -- Classification Functions --");
168 if Match (Line, Func_Hedr) then
171 elsif Match (Line, Func_Retn)
172 and then Accessfunc /= Get (Fields, Fieldnm)
173 and then Fieldnm /= "Mechanism"
175 Put_Line ("*** incorrect field at line " & Lineno);
176 Put_Line (" found field " & Accessfunc);
177 Put_Line (" expecting field " & Get (Fields, Fieldnm));
181 Put_Line ("Check references in set routines in body");
185 exit when Match (Line, " -- Attribute Set Procedures");
190 exit when Match (Line, " ------------");
192 if Match (Line, Proc_Hedr) then
195 elsif Match (Line, Proc_Setf)
196 and then Accessfunc /= Get (Fields, Fieldnm)
197 and then Fieldnm /= "Mechanism"
199 Put_Line ("*** incorrect field at line " & Lineno);
200 Put_Line (" found field " & Accessfunc);
201 Put_Line (" expecting field " & Get (Fields, Fieldnm));
205 Put_Line ("All tests completed successfully, no errors detected");