* config/alpha/alpha.c, config/alpha/alpha.md,
[official-gcc.git] / gcc / ada / ceinfo.adb
blob494b9077c47ba10eaac0192430815a27019a74cd
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 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 -- Program to check consistency of einfo.ads and einfo.adb. Checks that
28 -- field name usage is consistent, including comments mentioning fields.
30 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
31 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
32 with Ada.Text_IO; use Ada.Text_IO;
34 with GNAT.Spitbol; use GNAT.Spitbol;
35 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
36 with GNAT.Spitbol.Table_VString;
38 procedure CEinfo is
40 package TV renames GNAT.Spitbol.Table_VString;
41 use TV;
43 Infil : File_Type;
44 Lineno : Natural := 0;
46 Err : exception;
47 -- Raised on fatal error
49 Fieldnm : VString;
50 Accessfunc : VString;
51 Line : VString;
53 Fields : GNAT.Spitbol.Table_VString.Table (500);
54 -- Maps field names to underlying field access name
56 UC : Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
58 Fnam : Pattern := (UC & Break (' ')) * Fieldnm;
60 Field_Def : Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc;
62 Field_Ref : Pattern := " -- " & Fnam & Break ('(') & Len (1) &
63 Break (')') * Accessfunc;
65 Field_Com : Pattern := " -- " & Fnam & Span (' ') &
66 (Break (' ') or Rest) * Accessfunc;
68 Func_Hedr : Pattern := " function " & Fnam;
70 Func_Retn : Pattern := " return " & Break (' ') * Accessfunc;
72 Proc_Hedr : Pattern := " procedure " & Fnam;
74 Proc_Setf : Pattern := " Set_" & Break (' ') * Accessfunc;
76 procedure Next_Line;
77 -- Read next line trimmed from Infil into Line and bump Lineno
79 procedure Next_Line is
80 begin
81 Line := Get_Line (Infil);
82 Trim (Line);
83 Lineno := Lineno + 1;
84 end Next_Line;
86 -- Start of processing for CEinfo
88 begin
89 Anchored_Mode := True;
90 New_Line;
91 Open (Infil, In_File, "einfo.ads");
93 Put_Line ("Acquiring field names from spec");
95 loop
96 Next_Line;
97 exit when Match (Line, " -- Access Kinds --");
99 if Match (Line, Field_Def) then
100 Set (Fields, Fieldnm, Accessfunc);
101 end if;
102 end loop;
104 Put_Line ("Checking consistent references in spec");
106 loop
107 Next_Line;
108 exit when Match (Line, " -- Description of Defined");
109 end loop;
111 loop
112 Next_Line;
113 exit when Match (Line, " -- Component_Alignment Control");
115 if Match (Line, Field_Ref) then
116 if Accessfunc /= "synth"
117 and then
118 Accessfunc /= "special"
119 and then
120 Accessfunc /= Get (Fields, Fieldnm)
121 then
122 if Present (Fields, Fieldnm) then
123 Put_Line ("*** field name incorrect at line " & Lineno);
124 Put_Line (" found field " & Accessfunc);
125 Put_Line (" expecting field " & Get (Fields, Fieldnm));
127 else
128 Put_Line
129 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
130 end if;
131 end if;
132 end if;
133 end loop;
135 Close (Infil);
136 Open (Infil, In_File, "einfo.adb");
137 Lineno := 0;
139 Put_Line ("Check listing of fields in body");
141 loop
142 Next_Line;
143 exit when Match (Line, " -- Attribute Access Functions --");
145 if Match (Line, Field_Com)
146 and then Fieldnm /= "(unused)"
147 and then Accessfunc /= Get (Fields, Fieldnm)
148 then
149 if Present (Fields, Fieldnm) then
150 Put_Line ("*** field name incorrect at line " & Lineno);
151 Put_Line (" found field " & Accessfunc);
152 Put_Line (" expecting field " & Get (Fields, Fieldnm));
154 else
155 Put_Line
156 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
157 end if;
158 end if;
159 end loop;
161 Put_Line ("Check references in access routines in body");
163 loop
164 Next_Line;
165 exit when Match (Line, " -- Classification Functions --");
167 if Match (Line, Func_Hedr) then
168 null;
170 elsif Match (Line, Func_Retn)
171 and then Accessfunc /= Get (Fields, Fieldnm)
172 and then Fieldnm /= "Mechanism"
173 then
174 Put_Line ("*** incorrect field at line " & Lineno);
175 Put_Line (" found field " & Accessfunc);
176 Put_Line (" expecting field " & Get (Fields, Fieldnm));
177 end if;
178 end loop;
180 Put_Line ("Check references in set routines in body");
182 loop
183 Next_Line;
184 exit when Match (Line, " -- Attribute Set Procedures");
185 end loop;
187 loop
188 Next_Line;
189 exit when Match (Line, " ------------");
191 if Match (Line, Proc_Hedr) then
192 null;
194 elsif Match (Line, Proc_Setf)
195 and then Accessfunc /= Get (Fields, Fieldnm)
196 and then Fieldnm /= "Mechanism"
197 then
198 Put_Line ("*** incorrect field at line " & Lineno);
199 Put_Line (" found field " & Accessfunc);
200 Put_Line (" expecting field " & Get (Fields, Fieldnm));
201 end if;
202 end loop;
204 Put_Line ("All tests completed successfully, no errors detected");
206 end CEinfo;