[Ada] Spurious error with component of unchecked_union type

[thirdparty/gcc.git] / gcc / ada / ceinfo.adb

------------------------------------------------------------------------------
--                                                                          --
--                          GNAT SYSTEM UTILITIES                           --
--                                                                          --
--                               C E I N F O                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1998-2021, 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;