gcc/ada/xsnames.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                              X S N A M E S                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 --  This utility is used to make a new version of the Snames package when new
  27 --  names are added to the spec, the existing versions of snames.ads and
  28 --  snames.adb and snames.h are read, and updated to match the set of names in
  29 --  snames.ads. The updated versions are written to snames.ns, snames.nb (new
  30 --  spec/body), and snames.nh (new header file).
  31
  32 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  33 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  34 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  35 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  36 with Ada.Text_IO;                   use Ada.Text_IO;
  37
  38 with GNAT.Spitbol;                  use GNAT.Spitbol;
  39 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  40
  41 procedure XSnames is
  42
  43    InB  : File_Type;
  44    InS  : File_Type;
  45    OutS : File_Type;
  46    OutB : File_Type;
  47    InH  : File_Type;
  48    OutH : File_Type;
  49
  50    A, B  : VString := Nul;
  51    Line  : VString := Nul;
  52    Name  : VString := Nul;
  53    Name1 : VString := Nul;
  54    Oname : VString := Nul;
  55    Oval  : VString := Nul;
  56    Restl : VString := Nul;
  57
  58    Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
  59                                Any (Decimal_Digit_Set) &
  60                                Any (Decimal_Digit_Set);
  61
  62    Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
  63                                   & Span (' ') * B
  64                                   & ": constant Name_Id := N + " & Tdigs
  65                                   & ';' & Rest * Restl;
  66
  67    Get_Name : constant Pattern := "Name_" & Rest * Name1;
  68    Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
  69    Findu    : constant Pattern := Span ('u') * A;
  70
  71    Val : Natural;
  72
  73    Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
  74
  75    M : Match_Result;
  76
  77    type Header_Symbol is (None, Attr, Conv, Prag);
  78    --  A symbol in the header file
  79
  80    procedure Output_Header_Line (S : Header_Symbol);
  81    --  Output header line
  82
  83    Header_Attr : aliased String := "Attr";
  84    Header_Conv : aliased String := "Convention";
  85    Header_Prag : aliased String := "Pragma";
  86    --  Prefixes used in the header file
  87
  88    type String_Ptr is access all String;
  89    Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
  90                      (null,
  91                       Header_Attr'Access,
  92                       Header_Conv'Access,
  93                       Header_Prag'Access);
  94
  95    --  Patterns used in the spec file
  96
  97    Get_Attr : constant Pattern := Span (' ') & "Attribute_"
  98                                   & Break (",)") * Name1;
  99    Get_Conv : constant Pattern := Span (' ') & "Convention_"
 100                                   & Break (",)") * Name1;
 101    Get_Prag : constant Pattern := Span (' ') & "Pragma_"
 102                                   & Break (",)") * Name1;
 103
 104    type Header_Symbol_Counter is array (Header_Symbol) of Natural;
 105    Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
 106
 107    Header_Current_Symbol : Header_Symbol := None;
 108    Header_Pending_Line : VString := Nul;
 109
 110    ------------------------
 111    -- Output_Header_Line --
 112    ------------------------
 113
 114    procedure Output_Header_Line (S : Header_Symbol) is
 115    begin
 116       --  Skip all the #define for S-prefixed symbols in the header.
 117       --  Of course we are making implicit assumptions:
 118       --   (1) No newline between symbols with the same prefix.
 119       --   (2) Prefix order is the same as in snames.ads.
 120
 121       if Header_Current_Symbol /= S then
 122          declare
 123             Pat : constant String := "#define  " & Header_Prefix (S).all;
 124             In_Pat : Boolean := False;
 125
 126          begin
 127             if Header_Current_Symbol /= None then
 128                Put_Line (OutH, Header_Pending_Line);
 129             end if;
 130
 131             loop
 132                Line := Get_Line (InH);
 133
 134                if Match (Line, Pat) then
 135                   In_Pat := True;
 136                elsif In_Pat then
 137                   Header_Pending_Line := Line;
 138                   exit;
 139                else
 140                   Put_Line (OutH, Line);
 141                end if;
 142             end loop;
 143
 144             Header_Current_Symbol := S;
 145          end;
 146       end if;
 147
 148       --  Now output the line
 149
 150       Put_Line (OutH, "#define  " & Header_Prefix (S).all
 151                   & "_" & Name1 & (30 - Length (Name1)) * ' '
 152                   & Header_Counter (S));
 153       Header_Counter (S) := Header_Counter (S) + 1;
 154    end Output_Header_Line;
 155
 156 --  Start of processing for XSnames
 157
 158 begin
 159    Open (InB, In_File, "snames.adb");
 160    Open (InS, In_File, "snames.ads");
 161    Open (InH, In_File, "snames.h");
 162
 163    Create (OutS, Out_File, "snames.ns");
 164    Create (OutB, Out_File, "snames.nb");
 165    Create (OutH, Out_File, "snames.nh");
 166
 167    Anchored_Mode := True;
 168    Oname := Nul;
 169    Val := 0;
 170
 171    loop
 172       Line := Get_Line (InB);
 173       exit when Match (Line, "   Preset_Names");
 174       Put_Line (OutB, Line);
 175    end loop;
 176
 177    Put_Line (OutB, Line);
 178
 179    LoopN : while not End_Of_File (InS) loop
 180       Line := Get_Line (InS);
 181
 182       if not Match (Line, Name_Ref) then
 183          Put_Line (OutS, Line);
 184
 185          if Match (Line, Get_Attr) then
 186             Output_Header_Line (Attr);
 187          elsif Match (Line, Get_Conv) then
 188             Output_Header_Line (Conv);
 189          elsif Match (Line, Get_Prag) then
 190             Output_Header_Line (Prag);
 191          end if;
 192       else
 193          Oval := Lpad (V (Val), 3, '0');
 194
 195          if Match (Name, "Last_") then
 196             Oval := Lpad (V (Val - 1), 3, '0');
 197          end if;
 198
 199          Put_Line
 200            (OutS, A & Name & B & ": constant Name_Id := N + "
 201             & Oval & ';' & Restl);
 202
 203          if Match (Name, Get_Name) then
 204             Name := Name1;
 205             Val := Val + 1;
 206
 207             if Match (Name, Findu, M) then
 208                Replace (M, Translate (A, Xlate_U_Und));
 209                Translate (Name, Lower_Case_Map);
 210
 211             elsif not Match (Name, "Op_", "") then
 212                Translate (Name, Lower_Case_Map);
 213
 214             else
 215                Name := 'O' & Translate (Name, Lower_Case_Map);
 216             end if;
 217
 218             if Name = "error" then
 219                Name := V ("<error>");
 220             end if;
 221
 222             if not Match (Name, Chk_Low) then
 223                Put_Line (OutB, "     """ & Name & "#"" &");
 224             end if;
 225          end if;
 226       end if;
 227    end loop LoopN;
 228
 229    loop
 230       Line := Get_Line (InB);
 231       exit when Match (Line, "     ""#"";");
 232    end loop;
 233
 234    Put_Line (OutB, Line);
 235
 236    while not End_Of_File (InB) loop
 237       Line := Get_Line (InB);
 238       Put_Line (OutB, Line);
 239    end loop;
 240
 241    Put_Line (OutH, Header_Pending_Line);
 242    while not End_Of_File (InH) loop
 243       Line := Get_Line (InH);
 244       Put_Line (OutH, Line);
 245    end loop;
 246 end XSnames;