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-2023, 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    Name2 : VString := Nul;
  62    Oval  : VString := Nul;
  63    Restl : VString := Nul;
  64
  65    Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0
  66                                   & Span (' ') * B
  67                                   & ": constant Name_Id := N + $;"
  68                                   & Rest * Restl;
  69
  70    Get_Name : constant Pattern := "Name_" & Rest * Name1;
  71    Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
  72    Findu    : constant Pattern := Span ('u') * A;
  73    Is_Conv  : constant Pattern := "Convention_" & Rest;
  74
  75    Val : Natural;
  76
  77    Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
  78
  79    M : Match_Result;
  80
  81    type Header_Symbol is (None, Name, Attr, Conv, Prag);
  82    --  A symbol in the header file
  83
  84    procedure Output_Header_Line (S : Header_Symbol);
  85    --  Output header line
  86
  87    Header_Name : aliased String := "Name";
  88    Header_Attr : aliased String := "Attr";
  89    Header_Conv : aliased String := "Convention";
  90    Header_Prag : aliased String := "Pragma";
  91    --  Prefixes used in the header file
  92
  93    type String_Ptr is access all String;
  94    Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
  95                      (null,
  96                       Header_Name'Access,
  97                       Header_Attr'Access,
  98                       Header_Conv'Access,
  99                       Header_Prag'Access);
 100
 101    --  Patterns used in the spec file
 102
 103    Get_Attr  : constant Pattern := Span (' ') & "Attribute_"
 104                                    & Break (",)") * Name1;
 105    Get_Conv  : constant Pattern := Span (' ') & "Convention_"
 106                                    & Break (",)") * Name1;
 107    Get_Prag  : constant Pattern := Span (' ') & "Pragma_"
 108                                    & Break (",)") * Name1;
 109    Get_Subt1 : constant Pattern := Span (' ') & "subtype "
 110                                    & Break (' ') * Name1
 111                                    & " is " & Rest * Name2;
 112    Get_Subt2 : constant Pattern := Span (' ') & "range "
 113                                    & Break (' ') * Name1
 114                                    & " .. " & Break (";") * Name2;
 115
 116    type Header_Symbol_Counter is array (Header_Symbol) of Natural;
 117    Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
 118
 119    Header_Current_Symbol : Header_Symbol := None;
 120    Header_Pending_Line : VString := Nul;
 121
 122    --  Subtypes we will emit after an enum
 123
 124    Generated_C_Subtypes : Unbounded_String;
 125
 126    ------------------------
 127    -- Output_Header_Line --
 128    ------------------------
 129
 130    procedure Output_Header_Line (S : Header_Symbol) is
 131       function Make_Value (V : Integer) return String;
 132       --  Build the definition for the current enumerator (Names are integers
 133       --  offset to N, while other items are enumeration values).
 134
 135       ----------------
 136       -- Make_Value --
 137       ----------------
 138
 139       function Make_Value (V : Integer) return String is
 140       begin
 141          if S = Name then
 142             return "(First_Name_Id + 256 + " & V & ")";
 143          else
 144             return "" & V;
 145          end if;
 146       end Make_Value;
 147
 148    --  Start of processing for Output_Header_Line
 149
 150    begin
 151       --  Skip all the enumerator for S-prefixed symbols in the header.
 152       --  Of course we are making implicit assumptions:
 153       --   (1) No newline between symbols with the same prefix.
 154       --   (2) Prefix order is the same as in snames.ads.
 155
 156       if Header_Current_Symbol /= S then
 157          declare
 158             Pat : constant Pattern := "  "
 159                                        & Header_Prefix (S).all
 160                                        & Break (' ') * Name2;
 161             In_Pat : Boolean := False;
 162
 163          begin
 164             if Header_Current_Symbol /= None then
 165                Put_Line (OutH, Header_Pending_Line);
 166             end if;
 167
 168             loop
 169                Line := Get_Line (InH);
 170
 171                if Match (Line, Pat) then
 172                   In_Pat := True;
 173                elsif In_Pat then
 174                   Header_Pending_Line := Line;
 175                   exit;
 176                else
 177                   Put_Line (OutH, Line);
 178                end if;
 179             end loop;
 180
 181             Header_Current_Symbol := S;
 182          end;
 183       end if;
 184
 185       --  Now output the line
 186
 187       Put_Line (OutH, "  " & Header_Prefix (S).all
 188                   & "_" & Name1
 189                   & (30 - Natural'Min (29, Length (Name1))) * ' '
 190                   & " = "
 191                   & Make_Value (Header_Counter (S))
 192                   & ",");
 193       Header_Counter (S) := Header_Counter (S) + 1;
 194    end Output_Header_Line;
 195
 196 --  Start of processing for XSnames
 197
 198 begin
 199    Open (InS, In_File, "snames.ads-tmpl");
 200    Open (InB, In_File, "snames.adb-tmpl");
 201    Open (InH, In_File, "snames.h-tmpl");
 202
 203    --  Note that we do not generate snames.{ads,adb,h} directly. Instead
 204    --  we output them to snames.n{s,b,h} so that Makefiles can use
 205    --  move-if-change to not touch previously generated files if the
 206    --  new ones are identical.
 207
 208    Create (OutS, Out_File, "snames.ns");
 209    Create (OutB, Out_File, "snames.nb");
 210    Create (OutH, Out_File, "snames.nh");
 211
 212    Put_Line (OutH, "#ifdef __cplusplus");
 213    Put_Line (OutH, "extern ""C"" {");
 214    Put_Line (OutH, "#endif");
 215
 216    Anchored_Mode := True;
 217    Val := 0;
 218
 219    loop
 220       Line := Get_Line (InB);
 221       exit when Match (Line, "   Preset_Names");
 222       Put_Line (OutB, Line);
 223    end loop;
 224
 225    Put_Line (OutB, Line);
 226
 227    LoopN : while not End_Of_File (InS) loop
 228       Line := Get_Line (InS);
 229
 230       if not Match (Line, Name_Ref) then
 231          Put_Line (OutS, Line);
 232
 233          if Match (Line, Get_Attr) then
 234             Output_Header_Line (Attr);
 235          elsif Match (Line, Get_Conv) then
 236             Output_Header_Line (Conv);
 237          elsif Match (Line, Get_Prag) then
 238             Output_Header_Line (Prag);
 239          elsif Match (Line, Get_Subt1) and then Match (Name2, Is_Conv) then
 240             Generated_C_Subtypes := Generated_C_Subtypes & ASCII.LF
 241                                      & "SUBTYPE (" & Name1 & ", " & Name2
 242                                      & ", ";
 243          elsif Match (Line, Get_Subt2) and then Match (Name1, Is_Conv) then
 244             Generated_C_Subtypes := Generated_C_Subtypes & ASCII.LF
 245                                      & "   " & Name1 & ", " & Name2 & ')';
 246          end if;
 247       else
 248
 249          if Match (Name0, "Last_") then
 250             Oval := Lpad (V (Val - 1), 3, '0');
 251          else
 252             Oval := Lpad (V (Val), 3, '0');
 253          end if;
 254
 255          Put_Line
 256            (OutS, A & Name0 & B & ": constant Name_Id := N + "
 257             & Oval & ';' & Restl);
 258
 259          if Match (Name0, Get_Name) then
 260             Name0 := Name1;
 261             Val   := Val + 1;
 262
 263             if Match (Name0, Findu, M) then
 264                Replace (M, Translate (A, Xlate_U_Und));
 265                Translate (Name0, Lower_Case_Map);
 266
 267             elsif Match (Name0, "UP_", "") then
 268                Translate (Name0, Upper_Case_Map);
 269
 270             elsif Match (Name0, "Op_", "") then
 271                Name0 := 'O' & Translate (Name0, Lower_Case_Map);
 272
 273             else
 274                Translate (Name0, Lower_Case_Map);
 275             end if;
 276
 277             if not Match (Name0, Chk_Low) then
 278                Put_Line (OutB, "     """ & Name0 & "#"" &");
 279             end if;
 280
 281             Output_Header_Line (Name);
 282          end if;
 283       end if;
 284    end loop LoopN;
 285
 286    loop
 287       Line := Get_Line (InB);
 288       exit when Match (Line, "     ""#"";");
 289    end loop;
 290
 291    Put_Line (OutB, Line);
 292
 293    while not End_Of_File (InB) loop
 294       Line := Get_Line (InB);
 295       Put_Line (OutB, Line);
 296    end loop;
 297
 298    Put_Line (OutH, Header_Pending_Line);
 299    while not End_Of_File (InH) loop
 300       Line := Get_Line (InH);
 301       Put_Line (OutH, Line);
 302    end loop;
 303
 304    Put_Line (OutH, Generated_C_Subtypes);
 305    Put_Line (OutH, "");
 306    Put_Line (OutH, "#ifdef __cplusplus");
 307    Put_Line (OutH, "}");
 308    Put_Line (OutH, "#endif");
 309 end XSnamesT;