--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/ceinfo.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,226 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                               C E I N F O                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1998-2014, 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;