1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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).
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
;
40 with GNAT
.Spitbol
; use GNAT
.Spitbol
;
41 with GNAT
.Spitbol
.Patterns
; use GNAT
.Spitbol
.Patterns
;
43 with XUtil
; use XUtil
;
47 subtype VString
is GNAT
.Spitbol
.VString
;
49 InS
: Ada
.Text_IO
.File_Type
;
50 InB
: Ada
.Text_IO
.File_Type
;
51 InH
: Ada
.Text_IO
.File_Type
;
53 OutS
: Ada
.Streams
.Stream_IO
.File_Type
;
54 OutB
: Ada
.Streams
.Stream_IO
.File_Type
;
55 OutH
: Ada
.Streams
.Stream_IO
.File_Type
;
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
;
65 Name_Ref
: constant Pattern
:= Span
(' ') * A
& Break
(' ') * Name0
67 & ": constant Name_Id := N + $;"
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
;
77 Xlate_U_Und
: constant Character_Mapping
:= To_Mapping
("u", "_");
81 type Header_Symbol
is (None
, Name
, Attr
, Conv
, Prag
);
82 -- A symbol in the header file
84 procedure Output_Header_Line
(S
: Header_Symbol
);
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
93 type String_Ptr
is access all String;
94 Header_Prefix
: constant array (Header_Symbol
) of String_Ptr
:=
101 -- Patterns used in the spec file
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
;
116 type Header_Symbol_Counter
is array (Header_Symbol
) of Natural;
117 Header_Counter
: Header_Symbol_Counter
:= (0, 0, 0, 0, 0);
119 Header_Current_Symbol
: Header_Symbol
:= None
;
120 Header_Pending_Line
: VString
:= Nul
;
122 ------------------------
123 -- Output_Header_Line --
124 ------------------------
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).
135 function Make_Value
(V
: Integer) return String is
138 return "(First_Name_Id + 256 + " & V
& ")";
144 -- Start of processing for Output_Header_Line
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.
152 if Header_Current_Symbol
/= S
then
154 Pat
: constant Pattern
:= "#define "
155 & Header_Prefix
(S
).all
156 & Break
(' ') * Name2
;
157 In_Pat
: Boolean := False;
160 if Header_Current_Symbol
/= None
then
161 Put_Line
(OutH
, Header_Pending_Line
);
165 Line
:= Get_Line
(InH
);
167 if Match
(Line
, Pat
) then
170 Header_Pending_Line
:= Line
;
173 Put_Line
(OutH
, Line
);
177 Header_Current_Symbol
:= S
;
181 -- Now output the line
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
187 Put_Line
(OutH
, "#define " & Header_Prefix
(S
).all
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
;
194 -- Start of processing for XSnames
197 Open
(InS
, In_File
, "snames.ads-tmpl");
198 Open
(InB
, In_File
, "snames.adb-tmpl");
199 Open
(InH
, In_File
, "snames.h-tmpl");
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.
206 Create
(OutS
, Out_File
, "snames.ns");
207 Create
(OutB
, Out_File
, "snames.nb");
208 Create
(OutH
, Out_File
, "snames.nh");
210 Put_Line
(OutH
, "#ifdef __cplusplus");
211 Put_Line
(OutH
, "extern ""C"" {");
212 Put_Line
(OutH
, "#endif");
214 Anchored_Mode
:= True;
218 Line
:= Get_Line
(InB
);
219 exit when Match
(Line
, " Preset_Names");
220 Put_Line
(OutB
, Line
);
223 Put_Line
(OutB
, Line
);
225 LoopN
: while not End_Of_File
(InS
) loop
226 Line
:= Get_Line
(InS
);
228 if not Match
(Line
, Name_Ref
) then
229 Put_Line
(OutS
, Line
);
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
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
& ')');
245 if Match
(Name0
, "Last_") then
246 Oval
:= Lpad
(V
(Val
- 1), 3, '0');
248 Oval
:= Lpad
(V
(Val
), 3, '0');
252 (OutS
, A
& Name0
& B
& ": constant Name_Id := N + "
253 & Oval
& ';' & Restl
);
255 if Match
(Name0
, Get_Name
) then
259 if Match
(Name0
, Findu
, M
) then
260 Replace
(M
, Translate
(A
, Xlate_U_Und
));
261 Translate
(Name0
, Lower_Case_Map
);
263 elsif Match
(Name0
, "UP_", "") then
264 Translate
(Name0
, Upper_Case_Map
);
266 elsif Match
(Name0
, "Op_", "") then
267 Name0
:= 'O' & Translate
(Name0
, Lower_Case_Map
);
270 Translate
(Name0
, Lower_Case_Map
);
273 if not Match
(Name0
, Chk_Low
) then
274 Put_Line
(OutB
, " """ & Name0
& "#"" &");
277 Output_Header_Line
(Name
);
283 Line
:= Get_Line
(InB
);
284 exit when Match
(Line
, " ""#"";");
287 Put_Line
(OutB
, Line
);
289 while not End_Of_File
(InB
) loop
290 Line
:= Get_Line
(InB
);
291 Put_Line
(OutB
, Line
);
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
);
300 Put_Line
(OutH
, "#ifdef __cplusplus");
301 Put_Line
(OutH
, "}");
302 Put_Line
(OutH
, "#endif");