1168404Spjd------------------------------------------------------------------------------
2168404Spjd--                                                                          --
3168404Spjd--                          GNAT SYSTEM UTILITIES                           --
4168404Spjd--                                                                          --
5168404Spjd--                             X S N A M E S T                              --
6168404Spjd--                                                                          --
7168404Spjd--                                 B o d y                                  --
8168404Spjd--                                                                          --
9168404Spjd--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
10168404Spjd--                                                                          --
11168404Spjd-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12168404Spjd-- terms of the  GNU General Public License as published  by the Free Soft- --
13168404Spjd-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14168404Spjd-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15168404Spjd-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16168404Spjd-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17168404Spjd-- for  more details.  You should have  received  a copy of the GNU General --
18168404Spjd-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19168404Spjd-- http://www.gnu.org/licenses for a complete copy of the license.          --
20168404Spjd--                                                                          --
21168404Spjd-- GNAT was originally developed  by the GNAT team at  New York University. --
22219089Spjd-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23307279Smav--                                                                          --
24168404Spjd------------------------------------------------------------------------------
25168404Spjd
26168404Spjd--  This utility is used to make a new version of the Snames package when new
27168404Spjd--  names are added. This version reads a template file from snames.ads-tmpl in
28168404Spjd--  which the numbers are all written as $, and generates a new version of the
29168404Spjd--  spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl
30168404Spjd--  and generates an updated body (written to snames.nb), and snames.h-tmpl and
31168404Spjd--  generates an updated C header file (written to snames.nh).
32168404Spjd
33168404Spjdwith Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
34168404Spjdwith Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
35168404Spjdwith Ada.Strings.Maps;              use Ada.Strings.Maps;
36168404Spjdwith Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
37168404Spjdwith Ada.Text_IO;                   use Ada.Text_IO;
38168404Spjdwith Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
39262093Savg
40262093Savgwith GNAT.Spitbol;                  use GNAT.Spitbol;
41262093Savgwith GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
42209962Smm
43262093Savgwith XUtil;                         use XUtil;
44168404Spjd
45277553Sdelphijprocedure XSnamesT is
46277553Sdelphij
47269773Sdelphij   subtype VString is GNAT.Spitbol.VString;
48262093Savg
49269773Sdelphij   InS  : Ada.Text_IO.File_Type;
50269773Sdelphij   InB  : Ada.Text_IO.File_Type;
51269773Sdelphij   InH  : Ada.Text_IO.File_Type;
52262093Savg
53269773Sdelphij   OutS : Ada.Streams.Stream_IO.File_Type;
54269773Sdelphij   OutB : Ada.Streams.Stream_IO.File_Type;
55269773Sdelphij   OutH : Ada.Streams.Stream_IO.File_Type;
56269773Sdelphij
57262093Savg   A, B  : VString := Nul;
58307279Smav   Line  : VString := Nul;
59307279Smav   Name0 : VString := Nul;
60307279Smav   Name1 : VString := Nul;
61307279Smav   Oval  : VString := Nul;
62307279Smav   Restl : VString := Nul;
63307279Smav
64185029Spjd   Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0
65269773Sdelphij                                  & Span (' ') * B
66307279Smav                                  & ": constant Name_Id := N + $;"
67269773Sdelphij                                  & Rest * Restl;
68269773Sdelphij
69269773Sdelphij   Get_Name : constant Pattern := "Name_" & Rest * Name1;
70168404Spjd   Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
71269773Sdelphij   Findu    : constant Pattern := Span ('u') * A;
72269773Sdelphij
73269773Sdelphij   Val : Natural;
74269773Sdelphij
75269773Sdelphij   Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
76269773Sdelphij
77307279Smav   M : Match_Result;
78307279Smav
79307279Smav   type Header_Symbol is (None, Name, Attr, Conv, Prag);
80168404Spjd   --  A symbol in the header file
81269773Sdelphij
82269773Sdelphij   procedure Output_Header_Line (S : Header_Symbol);
83269773Sdelphij   --  Output header line
84269773Sdelphij
85269773Sdelphij   Header_Name : aliased String := "Name";
86269773Sdelphij   Header_Attr : aliased String := "Attr";
87262093Savg   Header_Conv : aliased String := "Convention";
88219089Spjd   Header_Prag : aliased String := "Pragma";
89269773Sdelphij   --  Prefixes used in the header file
90269773Sdelphij
91269773Sdelphij   type String_Ptr is access all String;
92269773Sdelphij   Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
93307279Smav                     (null,
94269773Sdelphij                      Header_Name'Access,
95269773Sdelphij                      Header_Attr'Access,
96269773Sdelphij                      Header_Conv'Access,
97269773Sdelphij                      Header_Prag'Access);
98307279Smav
99307279Smav   --  Patterns used in the spec file
100168404Spjd
101168404Spjd   Get_Attr : constant Pattern := Span (' ') & "Attribute_"
102168404Spjd                                  & Break (",)") * Name1;
103168404Spjd   Get_Conv : constant Pattern := Span (' ') & "Convention_"
104168404Spjd                                  & Break (",)") * Name1;
105168404Spjd   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
189begin
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");
288end XSnamesT;
289