aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/ceinfo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/ceinfo.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/ceinfo.adb204
1 files changed, 204 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/ceinfo.adb b/gcc-4.4.3/gcc/ada/ceinfo.adb
new file mode 100644
index 000000000..78e3faeb8
--- /dev/null
+++ b/gcc-4.4.3/gcc/ada/ceinfo.adb
@@ -0,0 +1,204 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT SYSTEM UTILITIES --
+-- --
+-- C E I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2008, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Program to check consistency of einfo.ads and einfo.adb. Checks that
+-- field name usage is consistent, including comments mentioning fields.
+
+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;
+
+ 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;
+ 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;
+ 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));
+ 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));
+ end if;
+ end loop;
+
+ Put_Line ("All tests completed successfully, no errors detected");
+
+end CEinfo;