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-2019, 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
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
226end CEinfo;
227