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