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-2018, 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       ----------------
 124       -- Make_Value --
 125       ----------------
 126
 127       function Make_Value (V : Integer) return String is
 128       begin
 129          if S = Name then
 130             return "(First_Name_Id + 256 + " & V & ")";
 131          else
 132             return "" & V;
 133          end if;
 134       end Make_Value;
 135
 136    --  Start of processing for Output_Header_Line
 137
 138    begin
 139       --  Skip all the #define for S-prefixed symbols in the header.
 140       --  Of course we are making implicit assumptions:
 141       --   (1) No newline between symbols with the same prefix.
 142       --   (2) Prefix order is the same as in snames.ads.
 143
 144       if Header_Current_Symbol /= S then
 145          declare
 146             Name2 : VString;
 147             Pat : constant Pattern := "#define  "
 148                                        & Header_Prefix (S).all
 149                                        & Break (' ') * Name2;
 150             In_Pat : Boolean := False;
 151
 152          begin
 153             if Header_Current_Symbol /= None then
 154                Put_Line (OutH, Header_Pending_Line);
 155             end if;
 156
 157             loop
 158                Line := Get_Line (InH);
 159
 160                if Match (Line, Pat) then
 161                   In_Pat := True;
 162                elsif In_Pat then
 163                   Header_Pending_Line := Line;
 164                   exit;
 165                else
 166                   Put_Line (OutH, Line);
 167                end if;
 168             end loop;
 169
 170             Header_Current_Symbol := S;
 171          end;
 172       end if;
 173
 174       --  Now output the line
 175
 176       --  Note that we must ensure at least one space between macro name and
 177       --  parens, otherwise the parenthesized value gets treated as an argument
 178       --  specification.
 179
 180       Put_Line (OutH, "#define  " & Header_Prefix (S).all
 181                   & "_" & Name1
 182                   & (30 - Natural'Min (29, Length (Name1))) * ' '
 183                   & Make_Value (Header_Counter (S)));
 184       Header_Counter (S) := Header_Counter (S) + 1;
 185    end Output_Header_Line;
 186
 187 --  Start of processing for XSnames
 188
 189 begin
 190    Open (InS, In_File, "snames.ads-tmpl");
 191    Open (InB, In_File, "snames.adb-tmpl");
 192    Open (InH, In_File, "snames.h-tmpl");
 193
 194    --  Note that we do not generate snames.{ads,adb,h} directly. Instead
 195    --  we output them to snames.n{s,b,h} so that Makefiles can use
 196    --  move-if-change to not touch previously generated files if the
 197    --  new ones are identical.
 198
 199    Create (OutS, Out_File, "snames.ns");
 200    Create (OutB, Out_File, "snames.nb");
 201    Create (OutH, Out_File, "snames.nh");
 202
 203    Put_Line (OutH, "#ifdef __cplusplus");
 204    Put_Line (OutH, "extern ""C"" {");
 205    Put_Line (OutH, "#endif");
 206
 207    Anchored_Mode := True;
 208    Val := 0;
 209
 210    loop
 211       Line := Get_Line (InB);
 212       exit when Match (Line, "   Preset_Names");
 213       Put_Line (OutB, Line);
 214    end loop;
 215
 216    Put_Line (OutB, Line);
 217
 218    LoopN : while not End_Of_File (InS) loop
 219       Line := Get_Line (InS);
 220
 221       if not Match (Line, Name_Ref) then
 222          Put_Line (OutS, Line);
 223
 224          if Match (Line, Get_Attr) then
 225             Output_Header_Line (Attr);
 226          elsif Match (Line, Get_Conv) then
 227             Output_Header_Line (Conv);
 228          elsif Match (Line, Get_Prag) then
 229             Output_Header_Line (Prag);
 230          end if;
 231       else
 232
 233          if Match (Name0, "Last_") then
 234             Oval := Lpad (V (Val - 1), 3, '0');
 235          else
 236             Oval := Lpad (V (Val), 3, '0');
 237          end if;
 238
 239          Put_Line
 240            (OutS, A & Name0 & B & ": constant Name_Id := N + "
 241             & Oval & ';' & Restl);
 242
 243          if Match (Name0, Get_Name) then
 244             Name0 := Name1;
 245             Val   := Val + 1;
 246
 247             if Match (Name0, Findu, M) then
 248                Replace (M, Translate (A, Xlate_U_Und));
 249                Translate (Name0, Lower_Case_Map);
 250
 251             elsif not Match (Name0, "Op_", "") then
 252                Translate (Name0, Lower_Case_Map);
 253
 254             else
 255                Name0 := 'O' & Translate (Name0, Lower_Case_Map);
 256             end if;
 257
 258             if not Match (Name0, Chk_Low) then
 259                Put_Line (OutB, "     """ & Name0 & "#"" &");
 260             end if;
 261
 262             Output_Header_Line (Name);
 263          end if;
 264       end if;
 265    end loop LoopN;
 266
 267    loop
 268       Line := Get_Line (InB);
 269       exit when Match (Line, "     ""#"";");
 270    end loop;
 271
 272    Put_Line (OutB, Line);
 273
 274    while not End_Of_File (InB) loop
 275       Line := Get_Line (InB);
 276       Put_Line (OutB, Line);
 277    end loop;
 278
 279    Put_Line (OutH, Header_Pending_Line);
 280    while not End_Of_File (InH) loop
 281       Line := Get_Line (InH);
 282       Put_Line (OutH, Line);
 283    end loop;
 284
 285    Put_Line (OutH, "#ifdef __cplusplus");
 286    Put_Line (OutH, "}");
 287    Put_Line (OutH, "#endif");
 288 end XSnamesT;