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