------------------------------------------------------------------------------ -- -- -- GNAT SYSTEM UTILITIES -- -- -- -- C E I N F O -- -- -- -- B o d y -- -- -- -- Copyright (C) 1998-2018, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- Check consistency of einfo.ads and einfo.adb. Checks that field name usage -- is consistent, including comments mentioning fields. -- Note that this is used both as a standalone program, and as a procedure -- called by XEinfo. This raises an unhandled exception if it finds any -- errors; we don't attempt any sophisticated error recovery. with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; with GNAT.Spitbol.Table_VString; procedure CEinfo is package TV renames GNAT.Spitbol.Table_VString; use TV; Infil : File_Type; Lineno : Natural := 0; Err : exception; -- Raised on error Fieldnm : VString; Accessfunc : VString; Line : VString; Fields : GNAT.Spitbol.Table_VString.Table (500); -- Maps field names to underlying field access name UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm; Field_Def : constant Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc; Field_Ref : constant Pattern := " -- " & Fnam & Break ('(') & Len (1) & Break (')') * Accessfunc; Field_Com : constant Pattern := " -- " & Fnam & Span (' ') & (Break (' ') or Rest) * Accessfunc; Func_Hedr : constant Pattern := " function " & Fnam; Func_Retn : constant Pattern := " return " & Break (' ') * Accessfunc; Proc_Hedr : constant Pattern := " procedure " & Fnam; Proc_Setf : constant Pattern := " Set_" & Break (' ') * Accessfunc; procedure Next_Line; -- Read next line trimmed from Infil into Line and bump Lineno procedure Next_Line is begin Line := Get_Line (Infil); Trim (Line); Lineno := Lineno + 1; end Next_Line; -- Start of processing for CEinfo begin Anchored_Mode := True; New_Line; Open (Infil, In_File, "einfo.ads"); Put_Line ("Acquiring field names from spec"); loop Next_Line; -- Old format of einfo.ads exit when Match (Line, " -- Access Kinds --"); -- New format of einfo.ads exit when Match (Line, "-- Access Kinds --"); if Match (Line, Field_Def) then Set (Fields, Fieldnm, Accessfunc); end if; end loop; Put_Line ("Checking consistent references in spec"); loop Next_Line; exit when Match (Line, " -- Description of Defined"); end loop; loop Next_Line; exit when Match (Line, " -- Component_Alignment Control"); if Match (Line, Field_Ref) then if Accessfunc /= "synth" and then Accessfunc /= "special" and then Accessfunc /= Get (Fields, Fieldnm) then if Present (Fields, Fieldnm) then Put_Line ("*** field name incorrect at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); else Put_Line ("*** unknown field name " & Fieldnm & " at line " & Lineno); end if; raise Err; end if; end if; end loop; Close (Infil); Open (Infil, In_File, "einfo.adb"); Lineno := 0; Put_Line ("Check listing of fields in body"); loop Next_Line; exit when Match (Line, " -- Attribute Access Functions --"); if Match (Line, Field_Com) and then Fieldnm /= "(unused)" and then Accessfunc /= Get (Fields, Fieldnm) then if Present (Fields, Fieldnm) then Put_Line ("*** field name incorrect at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); else Put_Line ("*** unknown field name " & Fieldnm & " at line " & Lineno); end if; raise Err; end if; end loop; Put_Line ("Check references in access routines in body"); loop Next_Line; exit when Match (Line, " -- Classification Functions --"); if Match (Line, Func_Hedr) then null; elsif Match (Line, Func_Retn) and then Accessfunc /= Get (Fields, Fieldnm) and then Fieldnm /= "Mechanism" then Put_Line ("*** incorrect field at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); raise Err; end if; end loop; Put_Line ("Check references in set routines in body"); loop Next_Line; exit when Match (Line, " -- Attribute Set Procedures"); end loop; loop Next_Line; exit when Match (Line, " ------------"); if Match (Line, Proc_Hedr) then null; elsif Match (Line, Proc_Setf) and then Accessfunc /= Get (Fields, Fieldnm) and then Fieldnm /= "Mechanism" then Put_Line ("*** incorrect field at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); raise Err; end if; end loop; Close (Infil); Put_Line ("All tests completed successfully, no errors detected"); end CEinfo;