File : 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-2014, 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;