gcc/ada/ceinfo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                               C E I N F O                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2008, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  Program to check consistency of einfo.ads and einfo.adb. Checks that
  27 --  field name usage is consistent, including comments mentioning fields.
  28
  29 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  30 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  31 with Ada.Text_IO;                   use Ada.Text_IO;
  32
  33 with GNAT.Spitbol;                  use GNAT.Spitbol;
  34 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  35 with GNAT.Spitbol.Table_VString;
  36
  37 procedure CEinfo is
  38
  39    package TV renames GNAT.Spitbol.Table_VString;
  40    use TV;
  41
  42    Infil  : File_Type;
  43    Lineno : Natural := 0;
  44
  45    Fieldnm    : VString;
  46    Accessfunc : VString;
  47    Line       : VString;
  48
  49    Fields : GNAT.Spitbol.Table_VString.Table (500);
  50    --  Maps field names to underlying field access name
  51
  52    UC : constant Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
  53
  54    Fnam : constant Pattern := (UC & Break (' ')) * Fieldnm;
  55
  56    Field_Def : constant Pattern :=
  57                  "--    " & Fnam & " (" & Break (')') * Accessfunc;
  58
  59    Field_Ref : constant Pattern :=
  60                  "   --    " & Fnam & Break ('(') & Len (1) &
  61                    Break (')') * Accessfunc;
  62
  63    Field_Com : constant Pattern := "   --    " & Fnam & Span (' ') &
  64                                      (Break (' ') or Rest) * Accessfunc;
  65
  66    Func_Hedr : constant Pattern := "   function " & Fnam;
  67
  68    Func_Retn : constant Pattern := "      return " & Break (' ') * Accessfunc;
  69
  70    Proc_Hedr : constant Pattern := "   procedure " & Fnam;
  71
  72    Proc_Setf : constant Pattern := "      Set_" & Break (' ') * Accessfunc;
  73
  74    procedure Next_Line;
  75    --  Read next line trimmed from Infil into Line and bump Lineno
  76
  77    procedure Next_Line is
  78    begin
  79       Line := Get_Line (Infil);
  80       Trim (Line);
  81       Lineno := Lineno + 1;
  82    end Next_Line;
  83
  84 --  Start of processing for CEinfo
  85
  86 begin
  87    Anchored_Mode := True;
  88    New_Line;
  89    Open (Infil, In_File, "einfo.ads");
  90
  91    Put_Line ("Acquiring field names from spec");
  92
  93    loop
  94       Next_Line;
  95       exit when Match (Line, "   -- Access Kinds --");
  96
  97       if Match (Line, Field_Def) then
  98          Set (Fields, Fieldnm, Accessfunc);
  99       end if;
 100    end loop;
 101
 102    Put_Line ("Checking consistent references in spec");
 103
 104    loop
 105       Next_Line;
 106       exit when Match (Line, "   -- Description of Defined");
 107    end loop;
 108
 109    loop
 110       Next_Line;
 111       exit when Match (Line, "   -- Component_Alignment Control");
 112
 113       if Match (Line, Field_Ref) then
 114          if Accessfunc /= "synth"
 115               and then
 116             Accessfunc /= "special"
 117               and then
 118             Accessfunc /= Get (Fields, Fieldnm)
 119          then
 120             if Present (Fields, Fieldnm) then
 121                Put_Line ("*** field name incorrect at line " & Lineno);
 122                Put_Line ("      found field " & Accessfunc);
 123                Put_Line ("      expecting field " & Get (Fields, Fieldnm));
 124
 125             else
 126                Put_Line
 127                  ("*** unknown field name " & Fieldnm & " at line " & Lineno);
 128             end if;
 129          end if;
 130       end if;
 131    end loop;
 132
 133    Close (Infil);
 134    Open (Infil, In_File, "einfo.adb");
 135    Lineno := 0;
 136
 137    Put_Line ("Check listing of fields in body");
 138
 139    loop
 140       Next_Line;
 141       exit when Match (Line, "   -- Attribute Access Functions --");
 142
 143       if Match (Line, Field_Com)
 144         and then Fieldnm /= "(unused)"
 145         and then Accessfunc /= Get (Fields, Fieldnm)
 146       then
 147          if Present (Fields, Fieldnm) then
 148             Put_Line ("*** field name incorrect at line " & Lineno);
 149             Put_Line ("      found field " & Accessfunc);
 150             Put_Line ("      expecting field " & Get (Fields, Fieldnm));
 151
 152          else
 153             Put_Line
 154               ("*** unknown field name " & Fieldnm & " at line " & Lineno);
 155          end if;
 156       end if;
 157    end loop;
 158
 159    Put_Line ("Check references in access routines in body");
 160
 161    loop
 162       Next_Line;
 163       exit when Match (Line, "   -- Classification Functions --");
 164
 165       if Match (Line, Func_Hedr) then
 166          null;
 167
 168       elsif Match (Line, Func_Retn)
 169         and then Accessfunc /= Get (Fields, Fieldnm)
 170         and then Fieldnm /= "Mechanism"
 171       then
 172          Put_Line ("*** incorrect field at line " & Lineno);
 173          Put_Line ("      found field " & Accessfunc);
 174          Put_Line ("      expecting field " & Get (Fields, Fieldnm));
 175       end if;
 176    end loop;
 177
 178    Put_Line ("Check references in set routines in body");
 179
 180    loop
 181       Next_Line;
 182       exit when Match (Line, "   -- Attribute Set Procedures");
 183    end loop;
 184
 185    loop
 186       Next_Line;
 187       exit when Match (Line, "   ------------");
 188
 189       if Match (Line, Proc_Hedr) then
 190          null;
 191
 192       elsif Match (Line, Proc_Setf)
 193         and then Accessfunc /= Get (Fields, Fieldnm)
 194         and then Fieldnm /= "Mechanism"
 195       then
 196          Put_Line ("*** incorrect field at line " & Lineno);
 197          Put_Line ("      found field " & Accessfunc);
 198          Put_Line ("      expecting field " & Get (Fields, Fieldnm));
 199       end if;
 200    end loop;
 201
 202    Put_Line ("All tests completed successfully, no errors detected");
 203
 204 end CEinfo;