1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
11 -- Copyright (C) 1998 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 -- Program to check consistency of einfo.ads and einfo.adb. Checks that
30 -- field name usage is consistent, including comments mentioning fields.
32 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
33 with Ada
.Strings
.Unbounded
.Text_IO
; use Ada
.Strings
.Unbounded
.Text_IO
;
34 with Ada
.Text_IO
; use Ada
.Text_IO
;
36 with GNAT
.Spitbol
; use GNAT
.Spitbol
;
37 with GNAT
.Spitbol
.Patterns
; use GNAT
.Spitbol
.Patterns
;
38 with GNAT
.Spitbol
.Table_VString
;
42 package TV
renames GNAT
.Spitbol
.Table_VString
;
46 Lineno
: Natural := 0;
49 -- Raised on fatal error
55 Fields
: GNAT
.Spitbol
.Table_VString
.Table
(500);
56 -- Maps field names to underlying field access name
58 UC
: Pattern
:= Any
("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
60 Fnam
: Pattern
:= (UC
& Break
(' ')) * Fieldnm
;
62 Field_Def
: Pattern
:= "-- " & Fnam
& " (" & Break
(')') * Accessfunc
;
64 Field_Ref
: Pattern
:= " -- " & Fnam
& Break
('(') & Len
(1) &
65 Break
(')') * Accessfunc
;
67 Field_Com
: Pattern
:= " -- " & Fnam
& Span
(' ') &
68 (Break
(' ') or Rest
) * Accessfunc
;
70 Func_Hedr
: Pattern
:= " function " & Fnam
;
72 Func_Retn
: Pattern
:= " return " & Break
(' ') * Accessfunc
;
74 Proc_Hedr
: Pattern
:= " procedure " & Fnam
;
76 Proc_Setf
: Pattern
:= " Set_" & Break
(' ') * Accessfunc
;
79 -- Read next line trimmed from Infil into Line and bump Lineno
81 procedure Next_Line
is
83 Line
:= Get_Line
(Infil
);
88 -- Start of processing for CEinfo
91 Anchored_Mode
:= True;
93 Open
(Infil
, In_File
, "einfo.ads");
95 Put_Line
("Acquiring field names from spec");
99 exit when Match
(Line
, " -- Access Kinds --");
101 if Match
(Line
, Field_Def
) then
102 Set
(Fields
, Fieldnm
, Accessfunc
);
106 Put_Line
("Checking consistent references in spec");
110 exit when Match
(Line
, " -- Description of Defined");
115 exit when Match
(Line
, " -- Component_Alignment Control");
117 if Match
(Line
, Field_Ref
) then
118 if Accessfunc
/= "synth"
120 Accessfunc
/= "special"
122 Accessfunc
/= Get
(Fields
, Fieldnm
)
124 if Present
(Fields
, Fieldnm
) then
125 Put_Line
("*** field name incorrect at line " & Lineno
);
126 Put_Line
(" found field " & Accessfunc
);
127 Put_Line
(" expecting field " & Get
(Fields
, Fieldnm
));
131 ("*** unknown field name " & Fieldnm
& " at line " & Lineno
);
138 Open
(Infil
, In_File
, "einfo.adb");
141 Put_Line
("Check listing of fields in body");
145 exit when Match
(Line
, " -- Attribute Access Functions --");
147 if Match
(Line
, Field_Com
)
148 and then Fieldnm
/= "(unused)"
149 and then Accessfunc
/= Get
(Fields
, Fieldnm
)
151 if Present
(Fields
, Fieldnm
) then
152 Put_Line
("*** field name incorrect at line " & Lineno
);
153 Put_Line
(" found field " & Accessfunc
);
154 Put_Line
(" expecting field " & Get
(Fields
, Fieldnm
));
158 ("*** unknown field name " & Fieldnm
& " at line " & Lineno
);
163 Put_Line
("Check references in access routines in body");
167 exit when Match
(Line
, " -- Classification Functions --");
169 if Match
(Line
, Func_Hedr
) then
172 elsif Match
(Line
, Func_Retn
)
173 and then Accessfunc
/= Get
(Fields
, Fieldnm
)
174 and then Fieldnm
/= "Mechanism"
176 Put_Line
("*** incorrect field at line " & Lineno
);
177 Put_Line
(" found field " & Accessfunc
);
178 Put_Line
(" expecting field " & Get
(Fields
, Fieldnm
));
182 Put_Line
("Check references in set routines in body");
186 exit when Match
(Line
, " -- Attribute Set Procedures");
191 exit when Match
(Line
, " ------------");
193 if Match
(Line
, Proc_Hedr
) then
196 elsif Match
(Line
, Proc_Setf
)
197 and then Accessfunc
/= Get
(Fields
, Fieldnm
)
198 and then Fieldnm
/= "Mechanism"
200 Put_Line
("*** incorrect field at line " & Lineno
);
201 Put_Line
(" found field " & Accessfunc
);
202 Put_Line
(" expecting field " & Get
(Fields
, Fieldnm
));
206 Put_Line
("All tests completed successfully, no errors detected");