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-2012, 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
33with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
34with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
35with Ada.Text_IO;                   use Ada.Text_IO;
36
37with GNAT.Spitbol;                  use GNAT.Spitbol;
38with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
39with GNAT.Spitbol.Table_VString;
40
41procedure 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
93begin
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      exit when Match (Line, "   -- Access Kinds --");
103
104      if Match (Line, Field_Def) then
105         Set (Fields, Fieldnm, Accessfunc);
106      end if;
107   end loop;
108
109   Put_Line ("Checking consistent references in spec");
110
111   loop
112      Next_Line;
113      exit when Match (Line, "   -- Description of Defined");
114   end loop;
115
116   loop
117      Next_Line;
118      exit when Match (Line, "   -- Component_Alignment Control");
119
120      if Match (Line, Field_Ref) then
121         if Accessfunc /= "synth"
122              and then
123            Accessfunc /= "special"
124              and then
125            Accessfunc /= Get (Fields, Fieldnm)
126         then
127            if Present (Fields, Fieldnm) then
128               Put_Line ("*** field name incorrect at line " & Lineno);
129               Put_Line ("      found field " & Accessfunc);
130               Put_Line ("      expecting field " & Get (Fields, Fieldnm));
131
132            else
133               Put_Line
134                 ("*** unknown field name " & Fieldnm & " at line " & Lineno);
135            end if;
136
137            raise Err;
138         end if;
139      end if;
140   end loop;
141
142   Close (Infil);
143   Open (Infil, In_File, "einfo.adb");
144   Lineno := 0;
145
146   Put_Line ("Check listing of fields in body");
147
148   loop
149      Next_Line;
150      exit when Match (Line, "   -- Attribute Access Functions --");
151
152      if Match (Line, Field_Com)
153        and then Fieldnm /= "(unused)"
154        and then Accessfunc /= Get (Fields, Fieldnm)
155      then
156         if Present (Fields, Fieldnm) then
157            Put_Line ("*** field name incorrect at line " & Lineno);
158            Put_Line ("      found field " & Accessfunc);
159            Put_Line ("      expecting field " & Get (Fields, Fieldnm));
160
161         else
162            Put_Line
163              ("*** unknown field name " & Fieldnm & " at line " & Lineno);
164         end if;
165
166         raise Err;
167      end if;
168   end loop;
169
170   Put_Line ("Check references in access routines in body");
171
172   loop
173      Next_Line;
174      exit when Match (Line, "   -- Classification Functions --");
175
176      if Match (Line, Func_Hedr) then
177         null;
178
179      elsif Match (Line, Func_Retn)
180        and then Accessfunc /= Get (Fields, Fieldnm)
181        and then Fieldnm /= "Mechanism"
182      then
183         Put_Line ("*** incorrect field at line " & Lineno);
184         Put_Line ("      found field " & Accessfunc);
185         Put_Line ("      expecting field " & Get (Fields, Fieldnm));
186         raise Err;
187      end if;
188   end loop;
189
190   Put_Line ("Check references in set routines in body");
191
192   loop
193      Next_Line;
194      exit when Match (Line, "   -- Attribute Set Procedures");
195   end loop;
196
197   loop
198      Next_Line;
199      exit when Match (Line, "   ------------");
200
201      if Match (Line, Proc_Hedr) then
202         null;
203
204      elsif Match (Line, Proc_Setf)
205        and then Accessfunc /= Get (Fields, Fieldnm)
206        and then Fieldnm /= "Mechanism"
207      then
208         Put_Line ("*** incorrect field at line " & Lineno);
209         Put_Line ("      found field " & Accessfunc);
210         Put_Line ("      expecting field " & Get (Fields, Fieldnm));
211         raise Err;
212      end if;
213   end loop;
214
215   Close (Infil);
216
217   Put_Line ("All tests completed successfully, no errors detected");
218
219end CEinfo;
220