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-2020, 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