From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/ceinfo.adb | 219 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 219 insertions(+) create mode 100644 gcc/ada/ceinfo.adb (limited to 'gcc/ada/ceinfo.adb') diff --git a/gcc/ada/ceinfo.adb b/gcc/ada/ceinfo.adb new file mode 100644 index 000000000..44e7c67db --- /dev/null +++ b/gcc/ada/ceinfo.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- C E I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2010, 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; + 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; -- cgit v1.2.3