1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1998-2008, 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");