gcc/ada/xsnamest.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                             X S N A M E S T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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. This version reads a template file from snames.ads-tmpl in
  28 --  which the numbers are all written as $, and generates a new version of the
  29 --  spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl
  30 --  and generates an updated body (written to snames.nb), and snames.h-tmpl and
  31 --  generates an updated C header file (written to snames.nh).
  32
  33 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  34 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  35 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  36 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  37 with Ada.Text_IO;                   use Ada.Text_IO;
  38 with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
  39
  40 with GNAT.Spitbol;                  use GNAT.Spitbol;
  41 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  42
  43 with XUtil;                         use XUtil;
  44
  45 procedure XSnamesT is
  46
  47    subtype VString is GNAT.Spitbol.VString;
  48
  49    InS  : Ada.Text_IO.File_Type;
  50    InB  : Ada.Text_IO.File_Type;
  51    InH  : Ada.Text_IO.File_Type;
  52
  53    OutS : Ada.Streams.Stream_IO.File_Type;
  54    OutB : Ada.Streams.Stream_IO.File_Type;
  55    OutH : Ada.Streams.Stream_IO.File_Type;
  56
  57    A, B  : VString := Nul;
  58    Line  : VString := Nul;
  59    Name0 : VString := Nul;
  60    Name1 : VString := Nul;
  61    Oval  : VString := Nul;
  62    Restl : VString := Nul;
  63
  64    Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0
  65                                   & Span (' ') * B
  66                                   & ": constant Name_Id := N + $;"
  67                                   & Rest * Restl;
  68
  69    Get_Name : constant Pattern := "Name_" & Rest * Name1;
  70    Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
  71    Findu    : constant Pattern := Span ('u') * A;
  72
  73    Val : Natural;
  74
  75    Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
  76
  77    M : Match_Result;
  78
  79    type Header_Symbol is (None, Name, Attr, Conv, Prag);
  80    --  A symbol in the header file
  81
  82    procedure Output_Header_Line (S : Header_Symbol);
  83    --  Output header line
  84
  85    Header_Name : aliased String := "Name";
  86    Header_Attr : aliased String := "Attr";
  87    Header_Conv : aliased String := "Convention";
  88    Header_Prag : aliased String := "Pragma";
  89    --  Prefixes used in the header file
  90
  91    type String_Ptr is access all String;
  92    Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
  93                      (null,
  94                       Header_Name'Access,
  95                       Header_Attr'Access,
  96                       Header_Conv'Access,
  97                       Header_Prag'Access);
  98
  99    --  Patterns used in the spec file
 100
 101    Get_Attr : constant Pattern := Span (' ') & "Attribute_"
 102                                   & Break (",)") * Name1;
 103    Get_Conv : constant Pattern := Span (' ') & "Convention_"
 104                                   & Break (",)") * Name1;
 105    Get_Prag : constant Pattern := Span (' ') & "Pragma_"
 106                                   & Break (",)") * Name1;
 107
 108    type Header_Symbol_Counter is array (Header_Symbol) of Natural;
 109    Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
 110
 111    Header_Current_Symbol : Header_Symbol := None;
 112    Header_Pending_Line : VString := Nul;
 113
 114    ------------------------
 115    -- Output_Header_Line --
 116    ------------------------
 117
 118    procedure Output_Header_Line (S : Header_Symbol) is
 119       function Make_Value (V : Integer) return String;
 120       --  Build the definition for the current macro (Names are integers
 121       --  offset to N, while other items are enumeration values).
 122
 123       function Make_Value (V : Integer) return String is
 124       begin
 125          if S = Name then
 126             return "(First_Name_Id + 256 + " & V & ")";
 127          else
 128             return "" & V;
 129          end if;
 130       end Make_Value;
 131
 132    begin
 133       --  Skip all the #define for S-prefixed symbols in the header.
 134       --  Of course we are making implicit assumptions:
 135       --   (1) No newline between symbols with the same prefix.
 136       --   (2) Prefix order is the same as in snames.ads.
 137
 138       if Header_Current_Symbol /= S then
 139          declare
 140             Name2 : VString;
 141             Pat : constant Pattern := "#define  "
 142                                        & Header_Prefix (S).all
 143                                        & Break (' ') * Name2;
 144             In_Pat : Boolean := False;
 145
 146          begin
 147             if Header_Current_Symbol /= None then
 148                Put_Line (OutH, Header_Pending_Line);
 149             end if;
 150
 151             loop
 152                Line := Get_Line (InH);
 153
 154                if Match (Line, Pat) then
 155                   In_Pat := True;
 156                elsif In_Pat then
 157                   Header_Pending_Line := Line;
 158                   exit;
 159                else
 160                   Put_Line (OutH, Line);
 161                end if;
 162             end loop;
 163
 164             Header_Current_Symbol := S;
 165          end;
 166       end if;
 167
 168       --  Now output the line
 169
 170       --  Note that we must ensure at least one space between macro name and
 171       --  parens, otherwise the parenthesized value gets treated as an argument
 172       --  specification.
 173
 174       Put_Line (OutH, "#define  " & Header_Prefix (S).all
 175                   & "_" & Name1
 176                   & (30 - Natural'Min (29, Length (Name1))) * ' '
 177                   & Make_Value (Header_Counter (S)));
 178       Header_Counter (S) := Header_Counter (S) + 1;
 179    end Output_Header_Line;
 180
 181 --  Start of processing for XSnames
 182
 183 begin
 184    Open (InS, In_File, "snames.ads-tmpl");
 185    Open (InB, In_File, "snames.adb-tmpl");
 186    Open (InH, In_File, "snames.h-tmpl");
 187
 188    --  Note that we do not generate snames.{ads,adb,h} directly. Instead
 189    --  we output them to snames.n{s,b,h} so that Makefiles can use
 190    --  move-if-change to not touch previously generated files if the
 191    --  new ones are identical.
 192
 193    Create (OutS, Out_File, "snames.ns");
 194    Create (OutB, Out_File, "snames.nb");
 195    Create (OutH, Out_File, "snames.nh");
 196
 197    Put_Line (OutH, "#ifdef __cplusplus");
 198    Put_Line (OutH, "extern ""C"" {");
 199    Put_Line (OutH, "#endif");
 200
 201    Anchored_Mode := True;
 202    Val := 0;
 203
 204    loop
 205       Line := Get_Line (InB);
 206       exit when Match (Line, "   Preset_Names");
 207       Put_Line (OutB, Line);
 208    end loop;
 209
 210    Put_Line (OutB, Line);
 211
 212    LoopN : while not End_Of_File (InS) loop
 213       Line := Get_Line (InS);
 214
 215       if not Match (Line, Name_Ref) then
 216          Put_Line (OutS, Line);
 217
 218          if Match (Line, Get_Attr) then
 219             Output_Header_Line (Attr);
 220          elsif Match (Line, Get_Conv) then
 221             Output_Header_Line (Conv);
 222          elsif Match (Line, Get_Prag) then
 223             Output_Header_Line (Prag);
 224          end if;
 225       else
 226          Oval := Lpad (V (Val), 3, '0');
 227
 228          if Match (Name0, "Last_") then
 229             Oval := Lpad (V (Val - 1), 3, '0');
 230          end if;
 231
 232          Put_Line
 233            (OutS, A & Name0 & B & ": constant Name_Id := N + "
 234             & Oval & ';' & Restl);
 235
 236          if Match (Name0, Get_Name) then
 237             Name0 := Name1;
 238             Val   := Val + 1;
 239
 240             if Match (Name0, Findu, M) then
 241                Replace (M, Translate (A, Xlate_U_Und));
 242                Translate (Name0, Lower_Case_Map);
 243
 244             elsif not Match (Name0, "Op_", "") then
 245                Translate (Name0, Lower_Case_Map);
 246
 247             else
 248                Name0 := 'O' & Translate (Name0, Lower_Case_Map);
 249             end if;
 250
 251             if Name0 = "error" then
 252                Name0 := V ("<error>");
 253             end if;
 254
 255             if not Match (Name0, Chk_Low) then
 256                Put_Line (OutB, "     """ & Name0 & "#"" &");
 257             end if;
 258
 259             Output_Header_Line (Name);
 260          end if;
 261       end if;
 262    end loop LoopN;
 263
 264    loop
 265       Line := Get_Line (InB);
 266       exit when Match (Line, "     ""#"";");
 267    end loop;
 268
 269    Put_Line (OutB, Line);
 270
 271    while not End_Of_File (InB) loop
 272       Line := Get_Line (InB);
 273       Put_Line (OutB, Line);
 274    end loop;
 275
 276    Put_Line (OutH, Header_Pending_Line);
 277    while not End_Of_File (InH) loop
 278       Line := Get_Line (InH);
 279       Put_Line (OutH, Line);
 280    end loop;
 281
 282    Put_Line (OutH, "#ifdef __cplusplus");
 283    Put_Line (OutH, "}");
 284    Put_Line (OutH, "#endif");
 285 end XSnamesT;